module Control.Effect.Class.Machinery.TH where
import Control.Effect.Class.Machinery.TH.Internal (
defaultEffDataNamer,
generateEffect,
generateEffectWith,
generateOrderUnifiedEffDataTySyn,
generateOrderUnifiedEffectClass,
unifyEffTypeParams,
)
import Control.Effect.Class.Machinery.TH.Send (deriveEffectSend)
import Control.Monad (unless, (<=<))
import Control.Monad.Writer (execWriterT, lift, tell)
import Data.Effect.Class.TH.Internal (
EffectOrder (FirstOrder, HigherOrder),
effMethods,
reifyEffectInfo,
)
import Data.Function ((&))
import Language.Haskell.TH (Dec, Name, Q, mkName, nameBase)
makeEffect ::
String ->
Name ->
Name ->
Q [Dec]
makeEffect :: String -> Name -> Name -> Q [Dec]
makeEffect String
clsU Name
clsF Name
clsH = do
String -> String -> Name -> Name -> Name -> Name -> Q [Dec]
makeEffectWith
String
clsU
(String
clsU forall a. Semigroup a => a -> a -> a
<> String
"D")
Name
clsF
(EffectOrder -> Name -> Name
defaultEffDataNamer EffectOrder
FirstOrder Name
clsF)
Name
clsH
(EffectOrder -> Name -> Name
defaultEffDataNamer EffectOrder
HigherOrder Name
clsH)
makeEffectF :: Name -> Q [Dec]
makeEffectF :: Name -> Q [Dec]
makeEffectF = EffectOrder -> EffectInfo -> Q [Dec]
generateEffect EffectOrder
FirstOrder forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo
makeEffectH :: Name -> Q [Dec]
makeEffectH :: Name -> Q [Dec]
makeEffectH = EffectOrder -> EffectInfo -> Q [Dec]
generateEffect EffectOrder
HigherOrder forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo
makeEffectWith ::
String ->
String ->
Name ->
Name ->
Name ->
Name ->
Q [Dec]
makeEffectWith :: String -> String -> Name -> Name -> Name -> Name -> Q [Dec]
makeEffectWith String
clsU String
dataU Name
clsF Name
dataI Name
clsH Name
dataS =
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT do
EffectInfo
infoF <- Name -> Q EffectInfo
reifyEffectInfo Name
clsF forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
EffectInfo
infoH <- Name -> Q EffectInfo
reifyEffectInfo Name
clsH forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
[Name]
pvs <- EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams EffectInfo
infoF EffectInfo
infoH forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
FirstOrder Name
dataI EffectInfo
infoF 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
EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
HigherOrder Name
dataS EffectInfo
infoH 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 -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass EffectInfo
infoF EffectInfo
infoH [Name]
pvs (String -> Name
mkName String
clsU) 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
[Name -> Name -> [Name] -> Name -> Q Dec
generateOrderUnifiedEffDataTySyn Name
dataI Name
dataS [Name]
pvs (String -> Name
mkName String
dataU)]
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 ()
makeEffectFWith :: String -> Name -> Q [Dec]
makeEffectFWith :: String -> Name -> Q [Dec]
makeEffectFWith String
dataI = EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
FirstOrder (String -> Name
mkName String
dataI) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo
makeEffectHWith :: String -> Name -> Q [Dec]
makeEffectHWith :: String -> Name -> Q [Dec]
makeEffectHWith String
dataS = EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
HigherOrder (String -> Name
mkName String
dataS) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo
makeEmptyEffect :: Name -> Q [Dec]
makeEmptyEffect :: Name -> Q [Dec]
makeEmptyEffect Name
effClsName = do
EffectInfo
info <- Name -> Q EffectInfo
reifyEffectInfo Name
effClsName
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ EffectInfo -> [MethodInterface]
effMethods EffectInfo
info) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"The effect class \'" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
effClsName forall a. Semigroup a => a -> a -> a
<> String
"\' is not empty.")
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend EffectInfo
info forall a. Maybe a
Nothing]
makeOrderUnifiedEffectClass :: Name -> Name -> String -> Q [Dec]
makeOrderUnifiedEffectClass :: Name -> Name -> String -> Q [Dec]
makeOrderUnifiedEffectClass Name
clsF Name
clsH String
clsU = do
EffectInfo
infoF <- Name -> Q EffectInfo
reifyEffectInfo Name
clsF
EffectInfo
infoH <- Name -> Q EffectInfo
reifyEffectInfo Name
clsH
[Name]
pvs <- EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams EffectInfo
infoF EffectInfo
infoH
EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass EffectInfo
infoF EffectInfo
infoH [Name]
pvs (String -> Name
mkName String
clsU)