module Data.Functor.Foldable.Extensions.TH
(
entangleFunctors
, entanglePair
) where
import Data.Functor.Foldable.Extensions
import Language.Haskell.TH
entangleFunctors :: [(Name, Name)] -> Q [Dec]
entangleFunctors = fmap concat . traverse (uncurry entanglePair)
entanglePair :: Name -> Name -> Q [Dec]
entanglePair sub top = pure [subHomInstance, subTypeInstance]
where
subTypeInstance = InstanceD Nothing [] (subType `AppT` topT) funTypeDecls
subHomInstance = InstanceD Nothing (fmap (AppT functor) [subFT, topFT]) (subHom `AppT` subFT `AppT` topFT `AppT` subT `AppT` topT) funDecls
functor = ConT ''Functor
subHom = ConT ''SubHom
subType = ConT ''SubType
toN = mkName . (++ "F") . show
mN = mkName . show
toF = ConT . toN
subFT = toF sub
topFT = toF top
subT = ConT sub
topT = ConT top
getConstructor = mkName . show
funTypeDecls = [FunD switchN [switchClause, switchBoringClause]]
switchClause = Clause [ConP (getConstructor top) [ConP (getConstructor sub) [VarP (mkName "a")]]] (NormalB (VarE (mkName "a"))) []
switchBoringClause = Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []
funDecls = [FunD homoN [homoComplicated, homoSimple]]
dummySig = SigE (VarE dummyN) topT
homoComplicated = Clause [(VarP taN), (VarP saN), (ConP (toN top) [VarP (mkName "top")])] atlas []
homoSimple = Clause [WildP, (VarP fN), (VarP eN)] body []
atlas = NormalB ((ConE (mN top)) `AppE` ((VarE dendroN) `AppE` dummySig `AppE` (VarE saN) `AppE` (VarE taN) `AppE` (VarE (mkName "top"))))
body = NormalB ((VarE fN) `AppE` (VarE eN))
homoN = mkName "homo"
switchN = mkName "switch"
dendroN = mkName "dendro"
dummyN = mkName "dummy"
fN = mkName "f"
eN = mkName "e"
saN = mkName "subAlg"
taN = mkName "topAlg"