module SubHask.TemplateHaskell.Mutable
( mkMutable
, mkMutablePrimRef
, mkMutableNewtype
)
where
import SubHask.TemplateHaskell.Common
import Prelude
import Control.Monad
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
mkMutable :: Q Type -> Q [Dec]
mkMutable = mkMutablePrimRef
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 x -> []
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'" )
)
[]
]
]
]
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'" )
)
[]
]
]
]