{-# 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,
doesGenerateLiftFOEPatternSynonyms,
doesGenerateLiftFOETypeSynonym,
EffectConf (..),
keyedSenderGenConf,
normalSenderGenConf,
taggedSenderGenConf,
warnFirstOrderInHOE,
SenderFunctionConf (..),
senderFnName,
doesGenerateSenderFnSignature,
senderFnDoc,
senderFnArgDoc,
senderFnConfs,
deriveHFunctor,
noDeriveHFunctor,
generateLiftFOETypeSynonym,
noGenerateLiftFOETypeSynonym,
generateLiftFOEPatternSynonyms,
noGenerateLiftFOEPatternSynonyms,
noGenerateNormalSenderFunction,
noGenerateTaggedSenderFunction,
noGenerateKeyedSenderFunction,
suppressFirstOrderInHigherOrderEffectWarning,
noGenerateSenderFunctionSignature,
) where
import Control.Monad (forM_, when)
import Control.Monad.Writer (execWriterT, lift, tell)
import Data.Default (Default (def))
import Data.Effect.HFunctor.TH.Internal (deriveHFunctor)
import Data.Effect.TH.Internal (
DataInfo,
EffClsInfo,
EffectClassConf (
EffectClassConf,
_confByEffect,
_doesDeriveHFunctor,
_doesGenerateLiftFOEPatternSynonyms,
_doesGenerateLiftFOETypeSynonym
),
EffectConf (
EffectConf,
_keyedSenderGenConf,
_normalSenderGenConf,
_taggedSenderGenConf,
_warnFirstOrderInHOE
),
EffectOrder (FirstOrder, HigherOrder),
MakeEffectConf (MakeEffectConf, unMakeEffectConf),
SenderFunctionConf (
_doesGenerateSenderFnSignature,
_senderFnArgDoc,
_senderFnDoc,
_senderFnName
),
alterEffectClassConf,
alterEffectConf,
confByEffect,
doesDeriveHFunctor,
doesGenerateLiftFOEPatternSynonyms,
doesGenerateLiftFOETypeSynonym,
doesGenerateSenderFnSignature,
genLiftFOEPatternSynonyms,
genLiftFOETypeSynonym,
genSenders,
generateLiftFOEPatternSynonyms,
generateLiftFOETypeSynonym,
keyedSenderGenConf,
noDeriveHFunctor,
noGenerateKeyedSenderFunction,
noGenerateLiftFOEPatternSynonyms,
noGenerateLiftFOETypeSynonym,
noGenerateNormalSenderFunction,
noGenerateSenderFunctionSignature,
noGenerateTaggedSenderFunction,
normalSenderGenConf,
orderOf,
reifyEffCls,
senderFnArgDoc,
senderFnConfs,
senderFnDoc,
senderFnName,
suppressFirstOrderInHigherOrderEffectWarning,
taggedSenderGenConf,
unMakeEffectConf,
warnFirstOrderInHOE,
)
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 = WriterT [Dec] Q () -> Q [Dec]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT do
[Name] -> (Name -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
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 Q (Info, DataInfo, EffClsInfo)
-> (Q (Info, DataInfo, EffClsInfo)
-> WriterT [Dec] Q (Info, DataInfo, EffClsInfo))
-> WriterT [Dec] Q (Info, DataInfo, EffClsInfo)
forall a b. a -> (a -> b) -> b
& Q (Info, DataInfo, EffClsInfo)
-> WriterT [Dec] Q (Info, DataInfo, EffClsInfo)
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
ecConf :: EffectClassConf
ecConf@EffectClassConf{Bool
Name -> EffectConf
_confByEffect :: EffectClassConf -> Name -> EffectConf
_doesDeriveHFunctor :: EffectClassConf -> Bool
_doesGenerateLiftFOEPatternSynonyms :: EffectClassConf -> Bool
_doesGenerateLiftFOETypeSynonym :: EffectClassConf -> Bool
_confByEffect :: Name -> EffectConf
_doesDeriveHFunctor :: Bool
_doesGenerateLiftFOETypeSynonym :: Bool
_doesGenerateLiftFOEPatternSynonyms :: Bool
..} <- EffClsInfo -> Q EffectClassConf
conf EffClsInfo
effClsInfo Q EffectClassConf
-> (Q EffectClassConf -> WriterT [Dec] Q EffectClassConf)
-> WriterT [Dec] Q EffectClassConf
forall a b. a -> (a -> b) -> b
& Q EffectClassConf -> WriterT [Dec] Q EffectClassConf
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
EffectClassConf -> EffClsInfo -> Q [Dec]
genSenders EffectClassConf
ecConf EffClsInfo
effClsInfo Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesGenerateLiftFOETypeSynonym do
EffClsInfo -> Dec
genLiftFOETypeSynonym EffClsInfo
effClsInfo Dec -> (Dec -> [Dec]) -> [Dec]
forall a b. a -> (a -> b) -> b
& Dec -> [Dec]
forall a. a -> [a]
singleton [Dec] -> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b. a -> (a -> b) -> b
& [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesGenerateLiftFOEPatternSynonyms do
EffClsInfo -> Q [Dec]
genLiftFOEPatternSynonyms EffClsInfo
effClsInfo Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
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 Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
[Name] -> (Name -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
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 Q (Info, DataInfo, EffClsInfo)
-> (Q (Info, DataInfo, EffClsInfo)
-> WriterT [Dec] Q (Info, DataInfo, EffClsInfo))
-> WriterT [Dec] Q (Info, DataInfo, EffClsInfo)
forall a b. a -> (a -> b) -> b
& Q (Info, DataInfo, EffClsInfo)
-> WriterT [Dec] Q (Info, DataInfo, EffClsInfo)
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
ecConf :: EffectClassConf
ecConf@EffectClassConf{Bool
Name -> EffectConf
_confByEffect :: EffectClassConf -> Name -> EffectConf
_doesDeriveHFunctor :: EffectClassConf -> Bool
_doesGenerateLiftFOEPatternSynonyms :: EffectClassConf -> Bool
_doesGenerateLiftFOETypeSynonym :: EffectClassConf -> Bool
_confByEffect :: Name -> EffectConf
_doesDeriveHFunctor :: Bool
_doesGenerateLiftFOETypeSynonym :: Bool
_doesGenerateLiftFOEPatternSynonyms :: Bool
..} <- EffClsInfo -> Q EffectClassConf
conf EffClsInfo
effClsInfo Q EffectClassConf
-> (Q EffectClassConf -> WriterT [Dec] Q EffectClassConf)
-> WriterT [Dec] Q EffectClassConf
forall a b. a -> (a -> b) -> b
& Q EffectClassConf -> WriterT [Dec] Q EffectClassConf
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
EffectClassConf -> EffClsInfo -> Q [Dec]
genSenders EffectClassConf
ecConf EffClsInfo
effClsInfo Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesDeriveHFunctor do
(Infinite (Q Type) -> Q Type) -> DataInfo -> Q [Dec]
deriveHFunctor (Q Type -> Infinite (Q Type) -> Q Type
forall a b. a -> b -> a
const (Q Type -> Infinite (Q Type) -> Q Type)
-> Q Type -> Infinite (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TupleT Int
0) DataInfo
dataInfo Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
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 Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
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 = EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
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' MakeEffectConf
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 #-}
makeEffect_ :: [Name] -> [Name] -> Q [Dec]
makeEffect_ :: [Name] -> [Name] -> Q [Dec]
makeEffect_ = MakeEffectConf
-> (EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec])
-> [Name]
-> [Name]
-> Q [Dec]
makeEffect' (MakeEffectConf
forall a. Default a => a
def MakeEffectConf
-> (MakeEffectConf -> MakeEffectConf) -> MakeEffectConf
forall a b. a -> (a -> b) -> b
& MakeEffectConf -> MakeEffectConf
noDeriveHFunctor) EffectOrder
-> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]
noExtTemplate
{-# INLINE makeEffect_ #-}
makeEffectH_ :: [Name] -> Q [Dec]
makeEffectH_ :: [Name] -> Q [Dec]
makeEffectH_ [Name]
sigs = [Name] -> [Name] -> Q [Dec]
makeEffect_ [] [Name]
sigs
{-# INLINE makeEffectH_ #-}