-- 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
               (c) 2020 Michael Szvetits
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable

This module provides @TemplateHaskell@ functions to generate the effect data types
(/instruction/s and /signature/s) for effect type classes.
-}
module Data.Effect.Class.TH where

import Control.Monad ((<=<))
import Data.Effect.Class.TH.Internal (
    EffectOrder (FirstOrder, HigherOrder),
    defaultEffectDataNamer,
    generateEffectDataByEffInfo,
    generateLiftInsPatternSynonyms,
    reifyEffectInfo,
 )
import Data.List qualified as L
import Language.Haskell.TH (mkName)
import Language.Haskell.TH.Syntax (Dec, Name, Q, nameBase)

-- | Generate /instruction/ and /signature/ data types from the effect class of the given name.
makeEffectDataWith ::
    -- | An effect order of an effect data type to generate.
    EffectOrder ->
    -- | A name of an effect data type to generate.
    String ->
    -- | The name of the effect class.
    Name ->
    Q [Dec]
makeEffectDataWith :: EffectOrder -> String -> Name -> Q [Dec]
makeEffectDataWith EffectOrder
order String
effDataName Name
effClsName =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a]
L.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectOrder -> Name -> EffectInfo -> Q (DataInfo (), Dec)
generateEffectDataByEffInfo EffectOrder
order (String -> Name
mkName String
effDataName)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q EffectInfo
reifyEffectInfo Name
effClsName

-- | Generate only an /instruction/ data type from the effect class of the given name.
makeInstructionWith :: String -> Name -> Q [Dec]
makeInstructionWith :: String -> Name -> Q [Dec]
makeInstructionWith = EffectOrder -> String -> Name -> Q [Dec]
makeEffectDataWith EffectOrder
FirstOrder

-- | Generate only a /signature/ data type from the effect class of the given name.
makeSignatureWith :: String -> Name -> Q [Dec]
makeSignatureWith :: String -> Name -> Q [Dec]
makeSignatureWith = EffectOrder -> String -> Name -> Q [Dec]
makeEffectDataWith EffectOrder
HigherOrder

-- | Generate /instruction/ and /signature/ data types from the effect class of the given name.
makeEffectData :: EffectOrder -> Name -> Q [Dec]
makeEffectData :: EffectOrder -> Name -> Q [Dec]
makeEffectData EffectOrder
order Name
effClsName =
    EffectOrder -> String -> Name -> Q [Dec]
makeEffectDataWith
        EffectOrder
order
        (EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
effClsName)
        Name
effClsName

-- | Generate only an /instruction/ data type from the effect class of the given name.
makeInstruction :: Name -> Q [Dec]
makeInstruction :: Name -> Q [Dec]
makeInstruction = EffectOrder -> Name -> Q [Dec]
makeEffectData EffectOrder
FirstOrder

-- | Generate only a /signature/ data type from the effect class of the given name.
makeSignature :: Name -> Q [Dec]
makeSignature :: Name -> Q [Dec]
makeSignature = EffectOrder -> Name -> Q [Dec]
makeEffectData EffectOrder
HigherOrder

{- |
Generate the pattern synonyms for instruction constructors:
@
    pattern Foobar x y = LiftIns (FoobarI x y)
@ .
-}
makeLiftInsPatternSynonyms :: Name -> Name -> Q [Dec]
makeLiftInsPatternSynonyms :: Name -> Name -> Q [Dec]
makeLiftInsPatternSynonyms Name
dataName = Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms Name
dataName forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q EffectInfo
reifyEffectInfo