{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Eta reduce" #-}

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2023 Sayo Koyoneda
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable
-}
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_ #-}