{-# 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 Yamada Ryo
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,
    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 #-}