{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Class.Machinery.TH.Internal where
import Control.Effect.Class (LiftIns)
import Control.Effect.Class.Machinery.HFunctor ((:+:))
import Control.Effect.Class.Machinery.TH.Send (deriveEffectSend)
import Control.Monad (when)
import Control.Monad.Writer (execWriterT, lift, tell)
import Data.Effect.Class.TH.HFunctor.Internal (deriveHFunctor, tyVarName)
import Data.Effect.Class.TH.Internal (
EffectInfo (EffectInfo, effName, effParamVars),
EffectOrder (FirstOrder, HigherOrder),
applyEffPVs,
defaultEffectDataNamer,
generateEffectDataByEffInfo,
generateLiftInsPatternSynonyms,
generateLiftInsTypeSynonym,
)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Kind qualified as K
import Language.Haskell.TH (
Dec,
Name,
Q,
TyVarBndr (PlainTV),
appT,
classD,
kindedTV,
mkName,
nameBase,
tySynD,
varT,
)
generateEffect :: EffectOrder -> EffectInfo -> Q [Dec]
generateEffect :: EffectOrder -> EffectInfo -> Q [Dec]
generateEffect EffectOrder
order EffectInfo
info =
EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith
EffectOrder
order
(String -> Name
mkName forall a b. (a -> b) -> a -> b
$ EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info)
EffectInfo
info
defaultEffDataNamer :: EffectOrder -> Name -> Name
defaultEffDataNamer :: EffectOrder -> Name -> Name
defaultEffDataNamer EffectOrder
order = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
generateEffectWith :: EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith :: EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
order Name
effDataName EffectInfo
info =
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT do
(DataInfo ()
effDataInfo, Dec
effData) <- EffectOrder -> Name -> EffectInfo -> Q (DataInfo (), Dec)
generateEffectDataByEffInfo EffectOrder
order Name
effDataName EffectInfo
info forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Dec
effData]
case EffectOrder
order of
EffectOrder
FirstOrder -> do
Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms Name
effDataName EffectInfo
info forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
[EffectInfo -> Name -> Q Dec
generateLiftInsTypeSynonym EffectInfo
info Name
effDataName] forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
EffectOrder
HigherOrder ->
forall flag. DataInfo flag -> Q [Dec]
deriveHFunctor DataInfo ()
effDataInfo forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
[EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend EffectInfo
info forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (EffectOrder
order, Name
effDataName)] forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
forall (f :: * -> *) a. Applicative f => a -> f a
pure EffectInfo
info
generateOrderUnifiedEffectClass :: EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass :: EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass EffectInfo
infoF EffectInfo
infoH [Name]
pvs Name
unifiedClsName = do
Type
fKind <- [t|K.Type -> K.Type|]
let f :: Name
f = String -> Name
mkName String
"f"
fKinded :: TyVarBndr ()
fKinded = Name
f Name -> Type -> TyVarBndr ()
`kindedTV` Type
fKind
[Type]
cxt <-
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ Name -> [Name] -> Q Type
applyEffPVs (EffectInfo -> Name
effName EffectInfo
infoF) [Name]
pvs forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f
, Name -> [Name] -> Q Type
applyEffPVs (EffectInfo -> Name
effName EffectInfo
infoH) [Name]
pvs forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f
]
let pvs' :: [TyVarBndr ()]
pvs' = [Name]
pvs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ())
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec
classD
(forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
cxt)
Name
unifiedClsName
([TyVarBndr ()]
pvs' forall a. [a] -> [a] -> [a]
++ [TyVarBndr ()
fKinded])
[]
[]
, EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend
( [Type]
-> Name
-> [TyVarBndr ()]
-> TyVarBndr ()
-> [MethodInterface]
-> EffectInfo
EffectInfo
[Type]
cxt
Name
unifiedClsName
[TyVarBndr ()]
pvs'
TyVarBndr ()
fKinded
[]
)
forall a. Maybe a
Nothing
]
generateOrderUnifiedEffDataTySyn :: Name -> Name -> [Name] -> Name -> Q Dec
generateOrderUnifiedEffDataTySyn :: Name -> Name -> [Name] -> Name -> Q Dec
generateOrderUnifiedEffDataTySyn Name
dataI Name
dataS [Name]
pvs Name
tySynName = do
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD
Name
tySynName
((forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
pvs)
[t|$(applyEffPVs dataS pvs) :+: LiftIns $(applyEffPVs dataI pvs)|]
unifyEffTypeParams :: EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams :: EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams EffectInfo
infoF EffectInfo
infoH = do
let pvF :: [String]
pvF = Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
infoF
pvH :: [String]
pvH = Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
infoH
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
pvF forall a. Eq a => a -> a -> Bool
/= [String]
pvH) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"The type parameter lists for the first and higher-order effect classes do not match:\n"
forall a. Semigroup a => a -> a -> a
<> (Name -> String
nameBase (EffectInfo -> Name
effName EffectInfo
infoF) forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [String]
pvF forall a. Semigroup a => a -> a -> a
<> String
"\n")
forall a. Semigroup a => a -> a -> a
<> (Name -> String
nameBase (EffectInfo -> Name
effName EffectInfo
infoH) forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [String]
pvH forall a. Semigroup a => a -> a -> a
<> String
"\n")
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
pvH