module Data.Derive.TopDown.Derive (
derivings
) where
import Data.Derive.TopDown.Utils
import Language.Haskell.TH
import Language.Haskell.TH.Utils
import Control.Monad (forM)
import Data.List (foldl')
import Control.Monad.State
import Control.Monad.Trans (lift)
import Debug.Trace
import qualified Language.Haskell.TH.Syntax as S
import Data.DeriveTH
derivings :: Name -> Derivation -> Name -> Q [Dec]
derivings className dv typeName = (fmap fst ((runStateT $ gen className typeName dv) []))
gen :: Name -> Name -> Derivation -> StateT [Type] Q [Dec]
gen cla tp dv = do
(cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp
let typeNames = map getTVBName tvbs
instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames
context <- lift $ applyContext cla typeNames
isMember <- if tvbs == []
then lift $ isInstance cla [instanceType]
else lift $ isInstance cla [ForallT tvbs cxt instanceType]
table <- get
if isMember || elem instanceType table
then return []
else do
let makeClassName = mkName $ "make" ++ nameBase cla
let tpname = nameBase tp
dec <- lift (derive dv tp)
modify (instanceType:)
let names = concatMap getCompositeType cons
xs <- mapM (\n -> gen cla n dv) names
return $ concat xs ++ dec
derivings' :: Name -> Name -> Q [Exp]
derivings' className typeName = (fmap fst ((runStateT $ gen' className typeName) []))
gen' :: Name -> Name -> StateT [Type] Q [Exp]
gen' cla tp = do
(cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp
let typeNames = map getTVBName tvbs
instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames
context <- lift $ applyContext cla typeNames
isMember <- if tvbs == []
then lift $ isInstance cla [instanceType]
else lift $ isInstance cla [ForallT tvbs cxt instanceType]
table <- get
if isMember || elem instanceType table
then return []
else do
let makeClassName = mkName $ "make" ++ nameBase cla
let tpname = nameBase tp
dec <- lift $ appExp [(varE (mkName "derive")), (varE makeClassName), (varE tp)]
lift [| derive $(varE makeClassName) tp |]
modify (instanceType:)
let names = concatMap getCompositeType cons
xs <- mapM (\n -> gen' cla n ) names
return $ concat xs ++ [dec]
derivings'' :: Name -> Name -> Q Exp
derivings'' cla typ = do
let makeClassName = mkName $ "make" ++ nameBase cla
a <- [| derive makeClassName (typ) |]
return a
instance S.Lift Name where
lift x = varE x
existentialTypeContainsClass :: Name -> Type -> Q Bool
existentialTypeContainsClass clss (ForallT _ cxt t) = return $ or $ map (boundByPred clss) cxt
boundByPred :: Name -> Pred -> Bool
boundByPred _ (EqualP _ _) = False
boundByPred c (ClassP clss _) = c == clss
t = [t| forall a b . (Eq a)=> (a,b) |]
t' = do
t1 <- t
return $ ForallT [PlainTV (mkName "a")] [ClassP ''Eq [VarT (mkName "a")]] t1
runTest = do
t1 <- t
existentialTypeContainsClass ''Eq t1