{-# 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.Send.Internal where

import Control.Effect.Class (
    EffectDataHandler,
    EffectsVia (EffectsVia),
    runEffectsVia,
    sendIns,
    sendSig,
 )
import Control.Effect.Class.Machinery.HFunctor (hfmap)
import Control.Monad (replicateM)
import Data.Effect.Class.TH.Internal (
    EffectOrder (FirstOrder, HigherOrder),
    MethodInterface (MethodInterface, methodName),
    methodOrder,
    methodParamTypes,
    methodReturnType,
 )
import Language.Haskell.TH (
    Dec,
    Inline (Inline),
    Name,
    Phases (AllPhases),
    Q,
    RuleMatch (FunLike),
    appE,
    appTypeE,
    clause,
    conE,
    funD,
    newName,
    normalB,
    pragInlD,
    varE,
    varP,
    varT,
 )

{- |
Generate a method implementation of the effect that handles via 'Control.Effect.Class.SendIns'/
'Control.Effect.Class.SendSig' type classes.
-}
effectMethodDec ::
    -- | The type parameters of the effect.
    [Name] ->
    -- | The interface of the effect method.
    MethodInterface ->
    -- | The name of effect data constructor corresponding to the method.
    Name ->
    Q [Dec]
effectMethodDec :: [Name] -> MethodInterface -> Name -> Q [Dec]
effectMethodDec [Name]
effTyVars MethodInterface{[Type]
Type
Name
EffectOrder
methodReturnType :: Type
methodParamTypes :: [Type]
methodOrder :: EffectOrder
methodName :: Name
methodReturnType :: MethodInterface -> Type
methodParamTypes :: MethodInterface -> [Type]
methodOrder :: MethodInterface -> EffectOrder
methodName :: MethodInterface -> Name
..} Name
conName = do
    [Name]
methodParams <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
methodParamTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")

    let con :: Q Exp
con = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
appTypeE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) (forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
effTyVars)

        effData :: Q Exp
effData = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
con (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
methodParams)

        sendMethod :: Q Exp
sendMethod = case EffectOrder
methodOrder of
            EffectOrder
FirstOrder -> [|sendIns|]
            EffectOrder
HigherOrder -> [|sendSig . hfmap runEffectsVia|]
        body :: Q Exp
body = [|EffectsVia @EffectDataHandler $ $sendMethod $effData|]

    Dec
funDef <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
methodName [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
methodParams) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
    Dec
funInline <- forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases

    forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
funDef, Dec
funInline]