{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Class.Machinery.TH.Send.Internal where
import Control.Effect.Class (
EffectDataHandler,
EffectsVia (EffectsVia),
runEffectsVia,
sendIns,
sendSig,
)
import Control.Effect.Class.Machinery.HFunctor (hfmap)
import Control.Monad (replicateM)
import Data.Effect.Class.TH.Internal (
EffectOrder (FirstOrder, HigherOrder),
MethodInterface (MethodInterface, methodName),
methodOrder,
methodParamTypes,
methodReturnType,
)
import Language.Haskell.TH (
Dec,
Inline (Inline),
Name,
Phases (AllPhases),
Q,
RuleMatch (FunLike),
appE,
appTypeE,
clause,
conE,
funD,
newName,
normalB,
pragInlD,
varE,
varP,
varT,
)
effectMethodDec ::
[Name] ->
MethodInterface ->
Name ->
Q [Dec]
effectMethodDec :: [Name] -> MethodInterface -> Name -> Q [Dec]
effectMethodDec [Name]
effTyVars MethodInterface{[Type]
Type
Name
EffectOrder
methodReturnType :: Type
methodParamTypes :: [Type]
methodOrder :: EffectOrder
methodName :: Name
methodReturnType :: MethodInterface -> Type
methodParamTypes :: MethodInterface -> [Type]
methodOrder :: MethodInterface -> EffectOrder
methodName :: MethodInterface -> Name
..} Name
conName = do
[Name]
methodParams <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
methodParamTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
let con :: Q Exp
con = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
appTypeE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) (forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
effTyVars)
effData :: Q Exp
effData = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
con (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
methodParams)
sendMethod :: Q Exp
sendMethod = case EffectOrder
methodOrder of
EffectOrder
FirstOrder -> [|sendIns|]
EffectOrder
HigherOrder -> [|sendSig . hfmap runEffectsVia|]
body :: Q Exp
body = [|EffectsVia @EffectDataHandler $ $sendMethod $effData|]
Dec
funDef <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
methodName [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
methodParams) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
Dec
funInline <- forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
funDef, Dec
funInline]