{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Eta reduce" #-}
module Data.Effect.TH (
module Data.Effect.TH,
module Data.Default,
module Data.Function,
EffectOrder (..),
orderOf,
MakeEffectConf (..),
alterEffectClassConf,
alterEffectConf,
EffectClassConf (..),
confByEffect,
doesDeriveHFunctor,
doesGenerateLiftInsPatternSynonyms,
doesGenerateLiftInsTypeSynonym,
EffectConf (..),
keyedSenderGenConf,
normalSenderGenConf,
taggedSenderGenConf,
warnFirstOrderInSigCls,
SenderFunctionConf (..),
senderFnName,
doesGenerateSenderFnSignature,
senderFnDoc,
senderFnArgDoc,
senderFnConfs,
deriveHFunctor,
noDeriveHFunctor,
generateLiftInsTypeSynonym,
noGenerateLiftInsTypeSynonym,
generateLiftInsPatternSynonyms,
noGenerateLiftInsPatternSynonyms,
noGenerateNormalSenderFunction,
noGenerateTaggedSenderFunction,
noGenerateKeyedSenderFunction,
suppressFirstOrderInSignatureClassWarning,
noGenerateSenderFunctionSignature,
) where
import Control.Monad.Writer (execWriterT, forM_, lift, tell, when)
import Data.Default (Default (def))
import Data.Effect.HFunctor.TH.Internal (deriveHFunctor)
import Data.Effect.TH.Internal (
DataInfo,
EffClsInfo,
EffectClassConf (
EffectClassConf,
_confByEffect,
_doesDeriveHFunctor,
_doesGenerateLiftInsPatternSynonyms,
_doesGenerateLiftInsTypeSynonym
),
EffectConf (
EffectConf,
_keyedSenderGenConf,
_normalSenderGenConf,
_taggedSenderGenConf,
_warnFirstOrderInSigCls
),
EffectOrder (FirstOrder, HigherOrder),
MakeEffectConf (MakeEffectConf, unMakeEffectConf),
SenderFunctionConf (
_doesGenerateSenderFnSignature,
_senderFnArgDoc,
_senderFnDoc,
_senderFnName
),
alterEffectClassConf,
alterEffectConf,
confByEffect,
doesDeriveHFunctor,
doesGenerateLiftInsPatternSynonyms,
doesGenerateLiftInsTypeSynonym,
doesGenerateSenderFnSignature,
genLiftInsPatternSynonyms,
genLiftInsTypeSynonym,
genSenders,
generateLiftInsPatternSynonyms,
generateLiftInsTypeSynonym,
keyedSenderGenConf,
noDeriveHFunctor,
noGenerateKeyedSenderFunction,
noGenerateLiftInsPatternSynonyms,
noGenerateLiftInsTypeSynonym,
noGenerateNormalSenderFunction,
noGenerateSenderFunctionSignature,
noGenerateTaggedSenderFunction,
normalSenderGenConf,
orderOf,
reifyEffCls,
senderFnArgDoc,
senderFnConfs,
senderFnDoc,
senderFnName,
suppressFirstOrderInSignatureClassWarning,
taggedSenderGenConf,
unMakeEffectConf,
warnFirstOrderInSigCls,
)
import Data.Function ((&))
import Data.List (singleton)
import Language.Haskell.TH (Dec, Info, Name, Q, Type (TupleT))
makeEffect' ::
MakeEffectConf ->
(EffectOrder -> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]) ->
[Name] ->
[Name] ->
Q [Dec]
makeEffect' :: MakeEffectConf
-> (EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec])
-> [Name]
-> [Name]
-> Q [Dec]
makeEffect' (MakeEffectConf EffClsInfo -> Q EffectClassConf
conf) EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
extTemplate [Name]
inss [Name]
sigs = forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Name]
inss \Name
ins -> do
(Info
info, DataInfo
dataInfo, EffClsInfo
effClsInfo) <- EffectOrder -> Name -> Q (Info, DataInfo, EffClsInfo)
reifyEffCls EffectOrder
FirstOrder Name
ins forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
ecConf :: EffectClassConf
ecConf@EffectClassConf{Bool
Name -> EffectConf
_doesGenerateLiftInsPatternSynonyms :: Bool
_doesGenerateLiftInsTypeSynonym :: Bool
_doesDeriveHFunctor :: Bool
_confByEffect :: Name -> EffectConf
_doesGenerateLiftInsTypeSynonym :: EffectClassConf -> Bool
_doesGenerateLiftInsPatternSynonyms :: EffectClassConf -> Bool
_doesDeriveHFunctor :: EffectClassConf -> Bool
_confByEffect :: EffectClassConf -> Name -> EffectConf
..} <- EffClsInfo -> Q EffectClassConf
conf EffClsInfo
effClsInfo forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
EffectClassConf -> EffClsInfo -> Q [Dec]
genSenders EffectClassConf
ecConf EffClsInfo
effClsInfo 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesGenerateLiftInsTypeSynonym do
EffClsInfo -> Dec
genLiftInsTypeSynonym EffClsInfo
effClsInfo forall a b. a -> (a -> b) -> b
& forall a. a -> [a]
singleton forall a b. a -> (a -> b) -> b
& forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesGenerateLiftInsPatternSynonyms do
EffClsInfo -> Q [Dec]
genLiftInsPatternSynonyms EffClsInfo
effClsInfo 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
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
extTemplate EffectOrder
FirstOrder Info
info DataInfo
dataInfo EffClsInfo
effClsInfo EffectClassConf
ecConf 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Name]
sigs \Name
sig -> do
(Info
info, DataInfo
dataInfo, EffClsInfo
effClsInfo) <- EffectOrder -> Name -> Q (Info, DataInfo, EffClsInfo)
reifyEffCls EffectOrder
HigherOrder Name
sig forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
ecConf :: EffectClassConf
ecConf@EffectClassConf{Bool
Name -> EffectConf
_doesGenerateLiftInsPatternSynonyms :: Bool
_doesGenerateLiftInsTypeSynonym :: Bool
_doesDeriveHFunctor :: Bool
_confByEffect :: Name -> EffectConf
_doesGenerateLiftInsTypeSynonym :: EffectClassConf -> Bool
_doesGenerateLiftInsPatternSynonyms :: EffectClassConf -> Bool
_doesDeriveHFunctor :: EffectClassConf -> Bool
_confByEffect :: EffectClassConf -> Name -> EffectConf
..} <- EffClsInfo -> Q EffectClassConf
conf EffClsInfo
effClsInfo forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
EffectClassConf -> EffClsInfo -> Q [Dec]
genSenders EffectClassConf
ecConf EffClsInfo
effClsInfo 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesDeriveHFunctor do
(Infinite (Q Type) -> Q Type) -> DataInfo -> Q [Dec]
deriveHFunctor (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Type
TupleT Int
0) DataInfo
dataInfo 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
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
extTemplate EffectOrder
HigherOrder Info
info DataInfo
dataInfo EffClsInfo
effClsInfo EffectClassConf
ecConf 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
noExtTemplate :: EffectOrder -> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
noExtTemplate :: EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
noExtTemplate = forall a. Monoid a => a
mempty
{-# INLINE noExtTemplate #-}
makeEffect :: [Name] -> [Name] -> Q [Dec]
makeEffect :: [Name] -> [Name] -> Q [Dec]
makeEffect = MakeEffectConf
-> (EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec])
-> [Name]
-> [Name]
-> Q [Dec]
makeEffect' forall a. Default a => a
def EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
noExtTemplate
{-# INLINE makeEffect #-}
makeEffectF :: [Name] -> Q [Dec]
makeEffectF :: [Name] -> Q [Dec]
makeEffectF [Name]
inss = [Name] -> [Name] -> Q [Dec]
makeEffect [Name]
inss []
{-# INLINE makeEffectF #-}
makeEffectH :: [Name] -> Q [Dec]
makeEffectH :: [Name] -> Q [Dec]
makeEffectH [Name]
sigs = [Name] -> [Name] -> Q [Dec]
makeEffect [] [Name]
sigs
{-# INLINE makeEffectH #-}