module Data.Functor.Free.TH where
import Data.Constraint hiding (Class)
import Data.Constraint.Class1
import Data.Algebra.TH
import Language.Haskell.TH.Syntax
deriveInstances' :: Bool -> Name -> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveInstances' withHSC forallLiftedNm dictLiftedNm freeNm liftAFreeNm showHelperNm nm = getSignatureInfo nm >>= h where
h sigInfo =
concat <$> sequenceA
[ deriveSignature nm
, deriveInstanceWith_skipSignature freeHeader $ return []
, deriveInstanceWith_skipSignature liftAFreeHeader $ return []
, deriveInstanceWith_skipSignature showHelperHeader $ return []
, deriveSuperclassInstances showHelperHeader
, hasSuperClassesInstance
, return $ [InstanceD Nothing [] (AppT (ConT forallLiftedNm) c) [ValD (VarP dictLiftedNm) (NormalB (ConE 'Dict)) []]]
]
where
freeHeader = return $ ForallT [PlainTV a, PlainTV vc] [AppT (AppT superClass1 c) (VarT vc)]
(AppT c (AppT (AppT free (VarT vc)) (VarT a)))
liftAFreeHeader = return $ ForallT [PlainTV f, PlainTV a, PlainTV vc] [AppT (ConT ''Applicative) (VarT f), isSC]
(AppT c (AppT (AppT (AppT liftAFree (VarT vc)) (VarT f)) (VarT a)))
showHelperHeader = return $ ForallT [PlainTV a] []
(AppT c (AppT (AppT showHelper sig) (VarT a)))
hasSuperClassesInstance = if withHSC then [d|instance HasSuperClasses $(pure c) where {
type SuperClasses $(pure c) = $(pure c) ': $(scs);
superClasses = Sub Dict;
containsSelf = Sub Dict
}|] else return []
scs = foldr (\(SuperclassTH scnm _ _) q -> [t|SuperClasses $(pure (ConT scnm)) ++ $(q)|]) [t|'[]|] $ superclasses sigInfo
isSC = AppT (AppT superClass1 c) (VarT vc)
free = ConT freeNm
liftAFree = ConT liftAFreeNm
showHelper = ConT showHelperNm
superClass1 = ConT ''SuperClass1
c = ConT nm
sig = ConT $ signatureName sigInfo
a = mkName "a"
f = mkName "f"
vc = mkName "c"