{-# LANGUAGE TemplateHaskell #-}

-- 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/.

module Control.Effect.Class.Machinery.TH.Internal where

import Control.Effect.Class (LiftIns)
import Control.Effect.Class.Machinery.HFunctor ((:+:))
import Control.Effect.Class.Machinery.TH.Send (deriveEffectSend)
import Control.Monad (when)
import Control.Monad.Writer (execWriterT, lift, tell)
import Data.Effect.Class.TH.HFunctor.Internal (deriveHFunctor, tyVarName)
import Data.Effect.Class.TH.Internal (
    EffectInfo (EffectInfo, effName, effParamVars),
    EffectOrder (FirstOrder, HigherOrder),
    applyEffPVs,
    defaultEffectDataNamer,
    generateEffectDataByEffInfo,
    generateLiftInsPatternSynonyms,
    generateLiftInsTypeSynonym,
 )
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Kind qualified as K
import Language.Haskell.TH (
    Dec,
    Name,
    Q,
    TyVarBndr (PlainTV),
    appT,
    classD,
    kindedTV,
    mkName,
    nameBase,
    tySynD,
    varT,
 )

generateEffect :: EffectOrder -> EffectInfo -> Q [Dec]
generateEffect :: EffectOrder -> EffectInfo -> Q [Dec]
generateEffect EffectOrder
order EffectInfo
info =
    EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith
        EffectOrder
order
        (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info)
        EffectInfo
info

defaultEffDataNamer :: EffectOrder -> Name -> Name
defaultEffDataNamer :: EffectOrder -> Name -> Name
defaultEffDataNamer EffectOrder
order = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

generateEffectWith :: EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith :: EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
order Name
effDataName EffectInfo
info =
    forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT do
        (DataInfo ()
effDataInfo, Dec
effData) <- EffectOrder -> Name -> EffectInfo -> Q (DataInfo (), Dec)
generateEffectDataByEffInfo EffectOrder
order Name
effDataName EffectInfo
info forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Dec
effData]

        case EffectOrder
order of
            EffectOrder
FirstOrder -> do
                Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms Name
effDataName EffectInfo
info 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 -> Name -> Q Dec
generateLiftInsTypeSynonym EffectInfo
info Name
effDataName] 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
            EffectOrder
HigherOrder ->
                forall flag. DataInfo flag -> Q [Dec]
deriveHFunctor DataInfo ()
effDataInfo 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 -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend EffectInfo
info forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (EffectOrder
order, Name
effDataName)] 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 EffectInfo
info

{- |
Generate the order-unified empty effect class:

    @class (FoobarF ... f, FoobarH ... f) => Foobar ... f@

, and derive an instance of the effect that handles via 'Control.Effect.Class.SendIns'/
'Control.Effect.Class.SendSig' instances.
-}
generateOrderUnifiedEffectClass :: EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass :: EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass EffectInfo
infoF EffectInfo
infoH [Name]
pvs Name
unifiedClsName = do
    Type
fKind <- [t|K.Type -> K.Type|]
    let f :: Name
f = String -> Name
mkName String
"f"
        fKinded :: TyVarBndr ()
fKinded = Name
f Name -> Type -> TyVarBndr ()
`kindedTV` Type
fKind

    [Type]
cxt <-
        forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ Name -> [Name] -> Q Type
applyEffPVs (EffectInfo -> Name
effName EffectInfo
infoF) [Name]
pvs forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f
            , Name -> [Name] -> Q Type
applyEffPVs (EffectInfo -> Name
effName EffectInfo
infoH) [Name]
pvs forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f
            ]
    let pvs' :: [TyVarBndr ()]
pvs' = [Name]
pvs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ())

    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec
classD
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
cxt)
            Name
unifiedClsName
            ([TyVarBndr ()]
pvs' forall a. [a] -> [a] -> [a]
++ [TyVarBndr ()
fKinded])
            []
            []
        , EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend
            ( [Type]
-> Name
-> [TyVarBndr ()]
-> TyVarBndr ()
-> [MethodInterface]
-> EffectInfo
EffectInfo
                [Type]
cxt
                Name
unifiedClsName
                [TyVarBndr ()]
pvs'
                TyVarBndr ()
fKinded
                []
            )
            forall a. Maybe a
Nothing
        ]

{- |
Generate the order-unified effect data type synonym:

    @type Foobar ... = FoobarS ... :+: LiftIns (FoobarI ...)@
-}
generateOrderUnifiedEffDataTySyn :: Name -> Name -> [Name] -> Name -> Q Dec
generateOrderUnifiedEffDataTySyn :: Name -> Name -> [Name] -> Name -> Q Dec
generateOrderUnifiedEffDataTySyn Name
dataI Name
dataS [Name]
pvs Name
tySynName = do
    forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD
        Name
tySynName
        ((forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
pvs)
        [t|$(applyEffPVs dataS pvs) :+: LiftIns $(applyEffPVs dataI pvs)|]

unifyEffTypeParams :: EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams :: EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams EffectInfo
infoF EffectInfo
infoH = do
    let pvF :: [String]
pvF = Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
infoF
        pvH :: [String]
pvH = Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
infoH

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
pvF forall a. Eq a => a -> a -> Bool
/= [String]
pvH) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            String
"The type parameter lists for the first and higher-order effect classes do not match:\n"
                forall a. Semigroup a => a -> a -> a
<> (Name -> String
nameBase (EffectInfo -> Name
effName EffectInfo
infoF) forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [String]
pvF forall a. Semigroup a => a -> a -> a
<> String
"\n")
                forall a. Semigroup a => a -> a -> a
<> (Name -> String
nameBase (EffectInfo -> Name
effName EffectInfo
infoH) forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [String]
pvH forall a. Semigroup a => a -> a -> a
<> String
"\n")

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
pvH