-- 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 generates automatically various data types and
instances that constitute the effect system supplied by the @classy-effects@ framework.
-}
module Control.Effect.Class.Machinery.TH where

import Control.Effect.Class.Machinery.TH.Internal (
    defaultEffDataNamer,
    generateEffect,
    generateEffectWith,
    generateOrderUnifiedEffDataTySyn,
    generateOrderUnifiedEffectClass,
    unifyEffTypeParams,
 )
import Control.Effect.Class.Machinery.TH.Send (deriveEffectSend)
import Control.Monad (unless, (<=<))
import Control.Monad.Writer (execWriterT, lift, tell)
import Data.Effect.Class.TH.Internal (
    EffectOrder (FirstOrder, HigherOrder),
    effMethods,
    reifyEffectInfo,
 )
import Data.Function ((&))
import Language.Haskell.TH (Dec, Name, Q, mkName, nameBase)

{- |
In addition to 'makeEffectF' and 'makeEffectH',
generate the order-unified empty effect class:

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

, and generate the order-unified effect data type synonym:

    @type Foobar ... = FoobarS ... :+: LiftIns (FoobarI ...)@
-}
makeEffect ::
    -- | A name of order-unified empty effect class generated newly
    String ->
    -- | The name of first-order effect class
    Name ->
    -- | The name of higher-order effect class
    Name ->
    Q [Dec]
makeEffect :: String -> Name -> Name -> Q [Dec]
makeEffect String
clsU Name
clsF Name
clsH = do
    String -> String -> Name -> Name -> Name -> Name -> Q [Dec]
makeEffectWith
        String
clsU
        (String
clsU forall a. Semigroup a => a -> a -> a
<> String
"D")
        Name
clsF
        (EffectOrder -> Name -> Name
defaultEffDataNamer EffectOrder
FirstOrder Name
clsF)
        Name
clsH
        (EffectOrder -> Name -> Name
defaultEffDataNamer EffectOrder
HigherOrder Name
clsH)

{- |
Generate an /instruction/ data type and type and pattern synonyms for abbreviating
'Control.Effect.Class.LiftIns'.
-}
makeEffectF :: Name -> Q [Dec]
makeEffectF :: Name -> Q [Dec]
makeEffectF = EffectOrder -> EffectInfo -> Q [Dec]
generateEffect EffectOrder
FirstOrder forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo

-- | Generate a /signature/ data type and a 'Data.Comp.Multi.HFunctor.HFunctor' instance.
makeEffectH :: Name -> Q [Dec]
makeEffectH :: Name -> Q [Dec]
makeEffectH = EffectOrder -> EffectInfo -> Q [Dec]
generateEffect EffectOrder
HigherOrder forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo

{- |
In addition to 'makeEffectF' and 'makeEffectH',
generate the order-unified empty effect class:

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

, and generate the order-unified effect data type synonym:

    @type Foobar ... = FoobarS ... :+: LiftIns (FoobarI ...)@
-}
makeEffectWith ::
    -- | A name of order-unified empty effect class generated newly
    String ->
    -- | A name of type synonym of order-unified effect data type generated newly
    String ->
    -- | The name of first-order effect class
    Name ->
    -- | The name of instruction data type corresponding to the first-order effect class
    Name ->
    -- | The name of higher-order effect class
    Name ->
    -- | The name of signature data type corresponding to the higher-order effect class
    Name ->
    Q [Dec]
makeEffectWith :: String -> String -> Name -> Name -> Name -> Name -> Q [Dec]
makeEffectWith String
clsU String
dataU Name
clsF Name
dataI Name
clsH Name
dataS =
    forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT do
        EffectInfo
infoF <- Name -> Q EffectInfo
reifyEffectInfo Name
clsF forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        EffectInfo
infoH <- Name -> Q EffectInfo
reifyEffectInfo Name
clsH forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

        [Name]
pvs <- EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams EffectInfo
infoF EffectInfo
infoH forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

        EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
FirstOrder Name
dataI EffectInfo
infoF 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 -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
HigherOrder Name
dataS EffectInfo
infoH 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 -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass EffectInfo
infoF EffectInfo
infoH [Name]
pvs (String -> Name
mkName String
clsU) 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

        [Name -> Name -> [Name] -> Name -> Q Dec
generateOrderUnifiedEffDataTySyn Name
dataI Name
dataS [Name]
pvs (String -> Name
mkName String
dataU)]
            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 ()

{- |
Generate an /instruction/ data type and type and pattern synonyms for abbreviating
'Control.Effect.Class.LiftIns'.
-}
makeEffectFWith :: String -> Name -> Q [Dec]
makeEffectFWith :: String -> Name -> Q [Dec]
makeEffectFWith String
dataI = EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
FirstOrder (String -> Name
mkName String
dataI) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo

-- | Generate a /signature/ data type and a 'Data.Comp.Multi.HFunctor.HFunctor' instance.
makeEffectHWith :: String -> Name -> Q [Dec]
makeEffectHWith :: String -> Name -> Q [Dec]
makeEffectHWith String
dataS = EffectOrder -> Name -> EffectInfo -> Q [Dec]
generateEffectWith EffectOrder
HigherOrder (String -> Name
mkName String
dataS) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo

{- |
Derive an instance of the effect, with no methods, that handles via 'Control.Effect.Class.SendIns'/
'Control.Effect.Class.SendSig' instances.
-}
makeEmptyEffect :: Name -> Q [Dec]
makeEmptyEffect :: Name -> Q [Dec]
makeEmptyEffect Name
effClsName = do
    EffectInfo
info <- Name -> Q EffectInfo
reifyEffectInfo Name
effClsName

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ EffectInfo -> [MethodInterface]
effMethods EffectInfo
info) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"The effect class \'" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
effClsName forall a. Semigroup a => a -> a -> a
<> String
"\' is not empty.")

    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [EffectInfo -> Maybe (EffectOrder, Name) -> Q Dec
deriveEffectSend EffectInfo
info forall a. Maybe a
Nothing]

{- |
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.
-}
makeOrderUnifiedEffectClass :: Name -> Name -> String -> Q [Dec]
makeOrderUnifiedEffectClass :: Name -> Name -> String -> Q [Dec]
makeOrderUnifiedEffectClass Name
clsF Name
clsH String
clsU = do
    EffectInfo
infoF <- Name -> Q EffectInfo
reifyEffectInfo Name
clsF
    EffectInfo
infoH <- Name -> Q EffectInfo
reifyEffectInfo Name
clsH
    [Name]
pvs <- EffectInfo -> EffectInfo -> Q [Name]
unifyEffTypeParams EffectInfo
infoF EffectInfo
infoH
    EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]
generateOrderUnifiedEffectClass EffectInfo
infoF EffectInfo
infoH [Name]
pvs (String -> Name
mkName String
clsU)