content: -- | Template Haskell functions for deriving "Mutable" instances.
  module SubHask.TemplateHaskell.Mutable
      ( mkMutable
      , mkMutablePrimRef
      , mkMutableNewtype
      )
      where
  
  import SubHask.TemplateHaskell.Common
  
  import Prelude
  import Language.Haskell.TH
  
  showtype :: Type -> String
  showtype t = map go (show t)
      where
          go ' ' = '_'
          go '.' = '_'
          go '[' = '_'
          go ']' = '_'
          go '(' = '_'
          go ')' = '_'
          go '/' = '_'
          go '+' = '_'
          go '>' = '_'
          go '<' = '_'
          go x   = x
  
  type2name :: Type -> Name
  type2name t = mkName $ "Mutable_"++showtype t
  
  -- | Inspects the given type and creates the most efficient "Mutable" instance possible.
  --
  -- FIXME: implement properly
  mkMutable :: Q Type -> Q [Dec]
  mkMutable = mkMutablePrimRef
  
  
  -- | Create a "Mutable" instance for newtype wrappers.
  -- The instance has the form:
  --
  -- > newtype instance Mutable m (TyCon t) = Mutable_TyCon (Mutable m t)
  --
  -- Also create the appropriate "IsMutable" instance.
  --
  -- FIXME:
  -- Currently uses default implementations which are slow.
  mkMutableNewtype :: Name -> Q [Dec]
  mkMutableNewtype typename = do
      typeinfo <- reify typename
      (conname,typekind,typeapp) <- case typeinfo of
          TyConI (NewtypeD [] _ typekind (NormalC conname [(  _,typeapp)]) _)
              -> return (conname,typekind,typeapp)
          TyConI (NewtypeD [] _ typekind (RecC    conname [(_,_,typeapp)]) _)
              -> return (conname,typekind,typeapp)
          _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo
  
      let mutname = mkName $ "Mutable_" ++ nameBase conname
  
      nameexists <- lookupValueName (show mutname)
      return $ case nameexists of
          Just _ -> []
          Nothing ->
              [ NewtypeInstD
                  [ ]
                  ( mkName $ "Mutable" )
                  [ VarT (mkName "m"), apply2varlist (ConT typename) typekind ]
                  ( NormalC
                      mutname
                      [( NotStrict
                       , AppT
                          ( AppT
                              ( ConT $ mkName "Mutable" )
                              ( VarT $ mkName "m" )
                          )
                          typeapp
                       )]
                  )
                  [ ]
              , InstanceD
                  ( map (\x -> AppT (ConT $ mkName "IsMutable") (bndr2type x)) $ filter isStar $ typekind )
                  ( AppT
                      ( ConT $ mkName "IsMutable" )
                      ( apply2varlist (ConT typename) typekind )
                  )
                  [ FunD (mkName "freeze")
                      [ Clause
                          [ ConP mutname [ VarP $ mkName "x" ] ]
                          ( NormalB $ AppE
                              ( AppE (VarE $ mkName "helper_liftM") (ConE conname) )
                              ( AppE (VarE $ mkName "freeze") (VarE $ mkName "x") )
                          )
                          []
                      ]
                  , FunD (mkName "thaw")
                      [ Clause
                          [ ConP conname [ VarP $ mkName "x" ] ]
                          ( NormalB $ AppE
                              ( AppE (VarE $ mkName "helper_liftM") (ConE mutname) )
                              ( AppE (VarE $ mkName "thaw") (VarE $ mkName "x") )
                          )
                          []
                      ]
                  , FunD (mkName "write")
                      [ Clause
                          [ ConP mutname [ VarP $ mkName "x" ]
                          , ConP conname [ VarP $ mkName "x'" ]
                          ]
                          ( NormalB $
                              AppE ( AppE (VarE $ mkName "write") (VarE $ mkName "x") ) (VarE $ mkName "x'" )
                          )
                          []
                      ]
                  ]
              ]
  
  -- | Create a "Mutable" instance that uses "PrimRef"s for the underlying implementation.
  -- This method will succeed for all types.
  -- But certain types can be implemented for efficiently.
  mkMutablePrimRef :: Q Type -> Q [Dec]
  mkMutablePrimRef qt = do
      _t <- qt
      let (cxt',t) = case _t of
              (ForallT _ cxt'' t') -> (cxt'',t')
              _                 -> ([],_t)
  
      return $
          [ NewtypeInstD
              cxt'
              ( mkName $ "Mutable" )
              [ VarT (mkName "m"), t ]
              ( NormalC
                  ( type2name t )
                  [( NotStrict
                   , AppT (AppT (ConT $ mkName "PrimRef") (VarT $ mkName "m")) t
                   )]
              )
              [ ]
          , InstanceD
              cxt'
              ( AppT ( ConT $ mkName "IsMutable" ) t )
              [ FunD (mkName "freeze")
                  [ Clause
                      [ ConP (type2name t) [ VarP $ mkName "x"] ]
                      ( NormalB $ AppE (VarE $ mkName "readPrimRef") (VarE $ mkName "x"))
                      []
                  ]
              , FunD (mkName "thaw")
                  [ Clause
                      [ VarP $ mkName "x" ]
                      ( NormalB $ AppE
                          ( AppE (VarE $ mkName "helper_liftM") (ConE $ type2name t) )
                          ( AppE (VarE $ mkName "newPrimRef") (VarE $ mkName "x") )
                      )
                      []
                  ]
              , FunD (mkName "write")
                  [ Clause
                      [ ConP (type2name t) [VarP $ mkName "x"], VarP $ mkName "x'" ]
                      ( NormalB $ AppE
                          ( AppE (VarE $ mkName "writePrimRef") (VarE $ mkName "x") )
                          ( VarE $ mkName "x'" )
                      )
                      []
                  ]
              ]
          ]
  
  