{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Control.Monad.Freer.TH
( makeEffect
, makeEffect_
)
where
import Control.Monad (forM, unless)
import Control.Monad.Freer (send, Member, Eff)
import Data.Char (toLower)
import Language.Haskell.TH
import Prelude
makeEffect :: Name -> Q [Dec]
makeEffect = genFreer True
makeEffect_ :: Name -> Q [Dec]
makeEffect_ = genFreer False
genFreer :: Bool -> Name -> Q [Dec]
genFreer makeSigs tcName = do
isExtEnabled FlexibleContexts
>>= flip unless (fail "makeEffect requires FlexibleContexts to be enabled")
reify tcName >>= \case
TyConI (DataD _ _ _ _ cons _) -> do
sigs <- filter (const makeSigs) <$> mapM genSig cons
decs <- mapM genDecl cons
return $ sigs ++ decs
_ -> fail "makeEffect expects a type constructor"
getDeclName :: Name -> Name
getDeclName = mkName . overFirst toLower . nameBase
where
overFirst f (a : as) = f a : as
overFirst _ as = as
genDecl :: Con -> Q Dec
genDecl (ForallC _ _ con) = genDecl con
genDecl (GadtC [cName] tArgs _ ) = do
let fnName = getDeclName cName
let arity = length tArgs - 1
dTypeVars <- forM [0 .. arity] $ const $ newName "a"
return $ FunD fnName . pure $ Clause
(VarP <$> dTypeVars)
(NormalB . AppE (VarE 'send) $ foldl
(\b -> AppE b . VarE)
(ConE cName)
dTypeVars
)
[]
genDecl _ = fail "genDecl expects a GADT constructor"
genType :: Con -> Q Type
genType (ForallC tyVarBindings conCtx con)
= ForallT tyVarBindings conCtx <$> genType con
genType (GadtC _ tArgs' (AppT eff tRet)) = do
effs <- newName "effs"
let
tArgs = fmap snd tArgs'
memberConstraint = ConT ''Member `AppT` eff `AppT` VarT effs
resultType = ConT ''Eff `AppT` VarT effs `AppT` tRet
return
. ForallT [PlainTV effs] [memberConstraint]
. foldArrows
$ tArgs
++ [resultType]
genType _ = fail "genSig expects a GADT constructor"
simplifyBndrs :: Type -> Type
simplifyBndrs (ForallT bndrs tcxt t) = ForallT (map simplifyBndr bndrs) tcxt (simplifyBndrs t)
simplifyBndrs (AppT t1 t2) = AppT (simplifyBndrs t1) (simplifyBndrs t2)
simplifyBndrs (SigT t k) = SigT (simplifyBndrs t) k
simplifyBndrs (InfixT t1 n t2) = InfixT (simplifyBndrs t1) n (simplifyBndrs t2)
simplifyBndrs (UInfixT t1 n t2) = InfixT (simplifyBndrs t1) n (simplifyBndrs t2)
simplifyBndrs (ParensT t) = ParensT (simplifyBndrs t)
simplifyBndrs t = t
simplifyBndr :: TyVarBndr -> TyVarBndr
simplifyBndr (KindedTV tv StarT) = PlainTV tv
simplifyBndr bndr = bndr
genSig :: Con -> Q Dec
genSig con = do
let
getConName (ForallC _ _ c) = getConName c
getConName (GadtC [n] _ _) = pure n
getConName c = fail $ "failed to get GADT name from " ++ show c
conName <- getConName con
SigD (getDeclName conName) <$> simplifyBndrs <$> genType con
foldArrows :: [Type] -> Type
foldArrows = foldr1 (AppT . AppT ArrowT)