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

{- |
Copyright   :  (c) 2023 Yamada Ryo
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable

This module provides @TemplateHaskell@ functions to derive an instance of the effect that handles
via 'SendIns'/'SendSig' type classes.
-}
module Control.Effect.Class.Machinery.TH.Send where

import Control.Effect.Class (EffectDataHandler, EffectsVia, SendIns, SendSig)
import Control.Effect.Class.Machinery.TH.Send.Internal (effectMethodDec)
import Control.Exception (assert)
import Control.Monad (forM)
import Data.Effect.Class.TH.HFunctor.Internal (tyVarName)
import Data.Effect.Class.TH.Internal (
    EffectInfo,
    EffectOrder (FirstOrder, HigherOrder),
    MethodInterface (MethodInterface, methodName),
    effMethods,
    effMonad,
    effName,
    effParamVars,
    effectParamCxt,
    reifyEffectInfo,
    renameMethodToCon,
    superEffects,
    tyVarType,
    unkindTyVar,
 )
import Data.Maybe (maybeToList)
import Language.Haskell.TH (
    Dec (InstanceD),
    Name,
    Q,
    Type (ConT),
    appT,
    conT,
    varT,
 )

-- | Derive an instance of the effect that handles via 'SendIns'/'SendSig' type classes.
makeEffectSend ::
    -- | The class name of the effect.
    Name ->
    -- | The name and order of effect data type corresponding to the effect.
    Maybe (EffectOrder, Name) ->
    Q [Dec]
makeEffectSend :: Name -> Maybe (EffectOrder, Name) -> Q [Dec]
makeEffectSend Name
effClsName Maybe (EffectOrder, Name)
effDataNameAndOrder = do
    EffectInfo
info <- Name -> Q EffectInfo
reifyEffectInfo Name
effClsName
    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend EffectInfo
info Maybe (EffectOrder, Name)
effDataNameAndOrder]

{- |
Derive an instance of the effect that handles via 'SendIns'/'SendSig' type classes, from
'EffectInfo'.
-}
deriveEffectSend ::
    -- | The reified information of the effect class.
    EffectInfo ->
    -- | The name and order of effect data type corresponding to the effect.
    Maybe (EffectOrder, Name) ->
    Q Dec
deriveEffectSend :: EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend EffectInfo
info Maybe (EffectOrder, Name)
effDataNameAndOrder = do
    let f :: Q Type
f = forall (m :: * -> *). Quote m => Name -> m Type
varT forall a b. (a -> b) -> a -> b
$ forall a. TyVarBndr a -> Name
tyVarName forall a b. (a -> b) -> a -> b
$ EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info

        pvs :: [TyVarBndr ()]
pvs = EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info
        paramTypes :: [Q Type]
paramTypes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. TyVarBndr a -> Q Type
tyVarType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar) [TyVarBndr ()]
pvs

        carrier :: Q Type
carrier = [t|EffectsVia EffectDataHandler $f|]

        methods :: [(MethodInterface, Name)]
methods =
            [ (MethodInterface
sig, Name -> Name
renameMethodToCon Name
methodName)
            | sig :: MethodInterface
sig@MethodInterface{Name
methodName :: Name
methodName :: MethodInterface -> Name
methodName} <- EffectInfo -> [MethodInterface]
effMethods EffectInfo
info
            ]

    [Type]
sendCxt <-
        forall a. Maybe a -> [a]
maybeToList
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (EffectOrder, Name)
effDataNameAndOrder \(EffectOrder
order, Name
effDataName) ->
                forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(MethodInterface, Name)]
methods) do
                    let sendCls :: Q Type
sendCls =
                            forall (m :: * -> *). Quote m => Name -> m Type
conT case EffectOrder
order of
                                EffectOrder
FirstOrder -> ''SendIns
                                EffectOrder
HigherOrder -> ''SendSig

                        effData :: Q Type
effData = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
effDataName) [Q Type]
paramTypes

                    [t|$sendCls $effData $f|]

    let effParamCxt :: [Type]
effParamCxt = EffectInfo -> [Type]
effectParamCxt EffectInfo
info

    [Type]
superEffCxt <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Type]
superEffects EffectInfo
info) ((forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
carrier) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)

    Type
effDataC <- do
        let eff :: Q Type
eff = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info
        [t|$(foldl appT eff paramTypes) $carrier|]

    [[Dec]]
decs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ [Name] -> MethodInterface -> Name -> Q [Dec]
effectMethodDec forall a b. (a -> b) -> a -> b
$ forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
pvs) [(MethodInterface, Name)]
methods

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing ([Type]
sendCxt forall a. [a] -> [a] -> [a]
++ [Type]
superEffCxt forall a. [a] -> [a] -> [a]
++ [Type]
effParamCxt) Type
effDataC (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs)