module SubHask.TemplateHaskell.Base
where
import qualified Prelude as Base
import qualified Control.Applicative as Base
import qualified Control.Monad as Base
import Language.Haskell.TH
import System.IO
import SubHask.Category
import SubHask.Algebra
import SubHask.Monad
import SubHask.Internal.Prelude
import Debug.Trace
type instance Logic Name = Bool
instance Eq_ Name where (==) = (Base.==)
type instance Logic Dec = Bool
instance Eq_ Dec where (==) = (Base.==)
type instance Logic Type = Bool
instance Eq_ Type where (==) = (Base.==)
deriveAll :: Q [Dec]
deriveAll = Base.liftM concat $ Base.mapM go
[ (''Base.Eq, mkPreludeEq)
, (''Base.Functor, mkPreludeFunctor)
, (''Base.Applicative,mkPreludeApplicative)
, (''Base.Monad,mkPreludeMonad)
]
where
go (n,f) = forAllInScope n f
forAllInScope :: Name -> (Cxt -> Q Type -> Q [Dec]) -> Q [Dec]
forAllInScope preludename f = do
info <- reify preludename
case info of
ClassI _ xs -> Base.liftM concat $ Base.sequence $ map mgo $ Base.filter fgo xs
where
mgo (InstanceD ctx (AppT _ t) _) = f ctx (Base.return t)
fgo (InstanceD _ (AppT _ t) _ ) = not elem '>' $ show t
runIfNotInstance :: Name -> Type -> Q [Dec] -> Q [Dec]
runIfNotInstance n t q = do
inst <- alreadyInstance n t
if inst
then trace ("skipping instance: "++show n++" / "++show t) $ Base.return []
else trace ("deriving instance: "++show n++" / "++show t) $ q
where
alreadyInstance :: Name -> Type -> Q Bool
alreadyInstance n t = do
info <- reify n
Base.return $ case info of
ClassI _ xs -> or $ map (genericTypeEq t.rmInstanceD) xs
genericTypeEq (AppT s1 t1) (AppT s2 t2) = genericTypeEq s1 s2 && genericTypeEq t1 t2
genericTypeEq (ConT n1) (ConT n2) = n1==n2
genericTypeEq (VarT _) (VarT _) = true
genericTypeEq (SigT _ _) (SigT _ _) = true
genericTypeEq (TupleT n1) (TupleT n2) = n1==n2
genericTypeEq ArrowT ArrowT = true
genericTypeEq ListT ListT = true
genericTypeEq _ _ = false
rmInstanceD (InstanceD _ (AppT _ t) _) = t
mkPreludeEq :: Cxt -> Q Type -> Q [Dec]
mkPreludeEq ctx qt = do
t <- qt
runIfNotInstance ''Eq_ t $ Base.return
[ TySynInstD
( mkName "Logic" )
( TySynEqn
[ t ]
( ConT $ mkName "Bool" )
)
, InstanceD
ctx
( AppT ( ConT $ mkName "Eq_" ) t )
[ FunD ( mkName "==" ) [ Clause [] (NormalB $ VarE $ mkName "Base.==") [] ]
]
]
mkPreludeFunctor :: Cxt -> Q Type -> Q [Dec]
mkPreludeFunctor ctx qt = do
t <- qt
runIfNotInstance ''Functor t $ Base.return
[ InstanceD
ctx
( AppT
( AppT
( ConT $ mkName "Functor" )
( ConT $ mkName "Hask" )
)
t
)
[ FunD ( mkName "fmap" ) [ Clause [] (NormalB $ VarE $ mkName "Base.fmap") [] ]
]
]
mkPreludeApplicative :: Cxt -> Q Type -> Q [Dec]
mkPreludeApplicative cxt qt = do
t <- qt
runIfNotInstance ''Applicative t $ Base.return
[ InstanceD
cxt
( AppT
( AppT
( ConT $ mkName "Applicative" )
( ConT $ mkName "Hask" )
)
t
)
[ FunD ( mkName "pure" ) [ Clause [] (NormalB $ VarE $ mkName "Base.pure") [] ]
, FunD ( mkName "<*>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<*>") [] ]
]
]
mkPreludeMonad :: Cxt -> Q Type -> Q [Dec]
mkPreludeMonad cxt qt = do
t <- qt
trace ("deriving instance: Monad / "++show t) $ if cannotDeriveMonad t
then Base.return []
else Base.return
[ InstanceD
cxt
( AppT
( ConT $ mkName "Then" )
t
)
[ FunD ( mkName ">>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>") [] ]
]
, InstanceD
( AppT (AppT (ConT ''Functor) (ConT ''Hask)) t : cxt )
( AppT
( AppT
( ConT $ mkName "Monad" )
( ConT $ mkName "Hask" )
)
t
)
[ FunD ( mkName "return_" ) [ Clause [] (NormalB $ VarE $ mkName "Base.return") [] ]
, FunD ( mkName "join" ) [ Clause [] (NormalB $ VarE $ mkName "Base.join" ) [] ]
, FunD ( mkName ">>=" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>=" ) [] ]
, FunD ( mkName ">=>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>=>" ) [] ]
, FunD ( mkName "=<<" ) [ Clause [] (NormalB $ VarE $ mkName "Base.=<<" ) [] ]
, FunD ( mkName "<=<" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<=<" ) [] ]
]
]
where
cannotDeriveMonad t = elem (show $ getName t) badmonad
where
getName :: Type -> Name
getName t = case t of
(ConT t) -> t
ListT -> mkName "[]"
(SigT t _) -> getName t
(AppT (ConT t) _) -> t
(AppT (AppT (ConT t) _) _) -> t
(AppT (AppT (AppT (ConT t) _) _) _) -> t
(AppT (AppT (AppT (AppT (ConT t) _) _) _) _) -> t
(AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) -> t
(AppT (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) _) -> t
t -> error ("cannotDeriveMonad error="++show t)
badmonad =
[ "Text.ParserCombinators.ReadBase.P"
, "Control.Monad.ST.Lazy.Imp.ST"
, "Data.Proxy.Proxy"
]