{-# LANGUAGE TemplateHaskellQuotes #-}

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

-- The code before modification is BSD3 licensed, (c) 2020 Michael Szvetits.
-- <https://github.com/typedbyte/effet/blob/master/src/Control/Effect/Machinery/TH.hs>

{- |
Copyright   :  (c) 2020 Michael Szvetits
               (c) 2023 Yamada Ryo
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable
-}
module Data.Effect.Class.TH.Internal where

import Control.Monad (forM, replicateM, unless, when)
import Control.Monad.IO.Class (MonadIO)
import Data.List (intercalate, nub)
import Language.Haskell.TH.Lib (
    appT,
    conT,
    patSynSigD,
    sigT,
    varT,
 )
import Language.Haskell.TH.Syntax (
    Con,
    Cxt,
    Dec (ClassD, SigD),
    Info (ClassI),
    Kind,
    Name,
    Q,
    Quote (newName),
    TyVarBndr (KindedTV, PlainTV),
    Type (
        AppKindT,
        AppT,
        ArrowT,
        ConT,
        ForallT,
        ImplicitParamT,
        InfixT,
        ParensT,
        PromotedT,
        SigT,
        StarT,
        UInfixT,
        VarT
    ),
    nameBase,
    reify,
 )

import Control.Effect.Class (LiftIns (LiftIns))
import Control.Lens ((%~), (^?), _head, _last)
import Control.Monad.Writer (Any (Any), runWriterT, tell)
import Data.Bool (bool)
import Data.Char (toUpper)
import Data.Effect.Class.TH.HFunctor.Internal (DataInfo (DataInfo), infoToDataD, tyVarName)
import Data.Either (partitionEithers)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List.Extra (dropEnd)
import Data.Maybe (isNothing, mapMaybe)
import Language.Haskell.TH (
    Bang (Bang),
    Con (ForallC, GadtC),
    SourceStrictness (NoSourceStrictness),
    SourceUnpackedness (NoSourceUnpackedness),
    Specificity (SpecifiedSpec),
    arrowT,
    conP,
    implBidir,
    mkName,
    patSynD,
    pragCompleteD,
    prefixPatSyn,
    tySynD,
    varP,
 )
import Language.Haskell.TH.Datatype (freeVariables)

-- | Generate /instruction/ and /signature/ data types from an effect class, from 'EffectInfo'.
generateEffectDataByEffInfo ::
    -- | An effect order of an effect data type to generate.
    EffectOrder ->
    -- | A name of an effect data type to generate.
    Name ->
    EffectInfo ->
    Q (DataInfo (), Dec)
generateEffectDataByEffInfo :: EffectOrder -> Name -> EffectInfo -> Q (DataInfo (), Dec)
generateEffectDataByEffInfo EffectOrder
order Name
effDataName EffectInfo
info = do
    DataInfo ()
effDataInfo <- do
        let pvs :: [TyVarBndr ()]
pvs = EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info

        [TyVarBndr ()]
additionalTypeParams <- do
            TyVarBndr ()
a <- do
                Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
a () Type
StarT

            forall (f :: * -> *) a. Applicative f => a -> f a
pure case EffectOrder
order of
                EffectOrder
FirstOrder -> [TyVarBndr ()
a]
                EffectOrder
HigherOrder -> [forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar forall a b. (a -> b) -> a -> b
$ EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info, TyVarBndr ()
a]

        [Con]
cons <- do
            ([(EffectOrder, String)]
errorMethods, [Con]
cons) <- do
                [(Name, (EffectOrder, Con))]
consWithMethodInfo <- do
                    Type
effData <- do
                        let 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
                        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

                    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [MethodInterface]
effMethods EffectInfo
info) \MethodInterface
method ->
                        (MethodInterface -> Name
methodName MethodInterface
method,)
                            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> Type -> MethodInterface -> Q (EffectOrder, Con)
interfaceToCon EffectInfo
info Type
effData MethodInterface
method

                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$
                    [(Name, (EffectOrder, Con))]
consWithMethodInfo forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
methodName, (EffectOrder
methodOrder, Con
con)) ->
                        if EffectOrder
methodOrder forall a. Eq a => a -> a -> Bool
== EffectOrder
order
                            then forall a b. b -> Either a b
Right Con
con
                            else forall a b. a -> Either a b
Left (EffectOrder
methodOrder, Name -> String
nameBase Name
methodName)

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(EffectOrder, String)]
errorMethods) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                    String
"Unexpected order of effect methods: "
                        forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate
                            String
", "
                            ( [(EffectOrder, String)]
errorMethods forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(EffectOrder
methodOrder, String
name) ->
                                String
name forall a. Semigroup a => a -> a -> a
<> String
" [" forall a. Semigroup a => a -> a -> a
<> [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ EffectOrder -> (Char, Char)
effectOrderSymbol EffectOrder
methodOrder] forall a. Semigroup a => a -> a -> a
<> String
"]"
                            )

            forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall flag.
[Type]
-> Name
-> [TyVarBndr flag]
-> [Con]
-> [DerivClause]
-> DataInfo flag
DataInfo [] Name
effDataName ([TyVarBndr ()]
pvs forall a. [a] -> [a] -> [a]
++ [TyVarBndr ()]
additionalTypeParams) [Con]
cons []

    forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataInfo ()
effDataInfo, DataInfo () -> Dec
infoToDataD DataInfo ()
effDataInfo)

-- | Convert an effect method interface to a constructor of the effect data type.
interfaceToCon ::
    EffectInfo ->
    Type ->
    MethodInterface ->
    Q (EffectOrder, Con)
interfaceToCon :: EffectInfo -> Type -> MethodInterface -> Q (EffectOrder, Con)
interfaceToCon EffectInfo
info Type
effData MethodInterface{[Type]
Type
Name
EffectOrder
methodCxt :: MethodInterface -> [Type]
methodReturnType :: MethodInterface -> Type
methodParamTypes :: MethodInterface -> [Type]
methodOrder :: MethodInterface -> EffectOrder
methodCxt :: [Type]
methodReturnType :: Type
methodParamTypes :: [Type]
methodOrder :: EffectOrder
methodName :: Name
methodName :: MethodInterface -> Name
..} =
    (EffectOrder
methodOrder,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Type
effDataFunctor <- case EffectOrder
methodOrder of
            EffectOrder
FirstOrder -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
effData
            EffectOrder
HigherOrder -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
effData forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Type -> Type
unkindType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TyVarBndr a -> Q Type
tyVarType (EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info))

        let vars :: [Name]
vars =
                forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                    (\[Name]
acc Type
t -> forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [Name]
acc forall a. [a] -> [a] -> [a]
++ forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t)
                    (forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info)
                    ([Type]
methodParamTypes forall a. [a] -> [a] -> [a]
++ [Type
methodReturnType])

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC ((forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` Specificity
SpecifiedSpec) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars) [Type]
methodCxt forall a b. (a -> b) -> a -> b
$
                [Name] -> [BangType] -> Type -> Con
GadtC
                    [Name -> Name
renameMethodToCon Name
methodName]
                    ([Type]
methodParamTypes forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,))
                    (Type -> Type -> Type
AppT Type
effDataFunctor Type
methodReturnType)

{- |
Decompose an effect method interface type to get the effect order, the list of argument types, and
the return type.
-}
analyzeMethodInterface :: TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, Cxt)
analyzeMethodInterface :: TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, [Type])
analyzeMethodInterface TyVarBndr ()
m Type
interface = do
    ((Type
resultType, [Type]
cxt, [Type]
paramTypes), Any Bool
isHigherOrderMethod) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ Type -> WriterT Any Q (Type, [Type], [Type])
go Type
interface
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> a -> Bool -> a
bool EffectOrder
FirstOrder EffectOrder
HigherOrder Bool
isHigherOrderMethod, [Type]
paramTypes, Type
resultType, [Type]
cxt)
  where
    go :: Type -> WriterT Any Q (Type, [Type], [Type])
go = \case
        Type
ArrowT `AppT` Type
l `AppT` Type
r -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
m Name -> Type -> Bool
`occurs` Type
l) forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type
l :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> WriterT Any Q (Type, [Type], [Type])
go Type
r
        ForallT [TyVarBndr Specificity]
_ [Type]
cxt Type
u -> do
            (Type
r, [Type]
c, [Type]
p) <- Type -> WriterT Any Q (Type, [Type], [Type])
go Type
u
            forall (m :: * -> *) a. Monad m => a -> m a
return (Type
r, [Type]
cxt forall a. [a] -> [a] -> [a]
++ [Type]
c, [Type]
p)
        VarT Name
n `AppT` Type
a | Name
n forall a. Eq a => a -> a -> Bool
== forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
m -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
a, [], [])
        Type
other -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected a pure type of the form 'm a', but encountered: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
other

-- | Convert a lower-camel-cased method name to an upper-camel-cased constructor name.
renameMethodToCon :: Name -> Name
renameMethodToCon :: Name -> Name
renameMethodToCon = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. Cons s s a a => Traversal' s a
_head forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Char -> Char
toUpper) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | An order of effect.
data EffectOrder = FirstOrder | HigherOrder
    deriving (Int -> EffectOrder -> String -> String
[EffectOrder] -> String -> String
EffectOrder -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EffectOrder] -> String -> String
$cshowList :: [EffectOrder] -> String -> String
show :: EffectOrder -> String
$cshow :: EffectOrder -> String
showsPrec :: Int -> EffectOrder -> String -> String
$cshowsPrec :: Int -> EffectOrder -> String -> String
Show, EffectOrder -> EffectOrder -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EffectOrder -> EffectOrder -> Bool
$c/= :: EffectOrder -> EffectOrder -> Bool
== :: EffectOrder -> EffectOrder -> Bool
$c== :: EffectOrder -> EffectOrder -> Bool
Eq, Eq EffectOrder
EffectOrder -> EffectOrder -> Bool
EffectOrder -> EffectOrder -> Ordering
EffectOrder -> EffectOrder -> EffectOrder
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EffectOrder -> EffectOrder -> EffectOrder
$cmin :: EffectOrder -> EffectOrder -> EffectOrder
max :: EffectOrder -> EffectOrder -> EffectOrder
$cmax :: EffectOrder -> EffectOrder -> EffectOrder
>= :: EffectOrder -> EffectOrder -> Bool
$c>= :: EffectOrder -> EffectOrder -> Bool
> :: EffectOrder -> EffectOrder -> Bool
$c> :: EffectOrder -> EffectOrder -> Bool
<= :: EffectOrder -> EffectOrder -> Bool
$c<= :: EffectOrder -> EffectOrder -> Bool
< :: EffectOrder -> EffectOrder -> Bool
$c< :: EffectOrder -> EffectOrder -> Bool
compare :: EffectOrder -> EffectOrder -> Ordering
$ccompare :: EffectOrder -> EffectOrder -> Ordering
Ord)

-- | Is the order of effect higher-order?
isHigherOrder :: EffectOrder -> Bool
isHigherOrder :: EffectOrder -> Bool
isHigherOrder = \case
    EffectOrder
FirstOrder -> Bool
False
    EffectOrder
HigherOrder -> Bool
True

{- |
The default naming convention of effect data types.

Add an @I@ or @S@ symbol indicating the order of the effect to the end of the effect class name.

If the name of the effect class ends in @F@ or @H@, depending on its order, replace @F@ or @H@ with
@I@ or @S@.
-}
defaultEffectDataNamer :: EffectOrder -> String -> String
defaultEffectDataNamer :: EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order String
clsName =
    String
effNameBase forall a. [a] -> [a] -> [a]
++ [Char
dataOrderSym]
  where
    (Char
clsOrderSym, Char
dataOrderSym) = EffectOrder -> (Char, Char)
effectOrderSymbol EffectOrder
order
    effNameBase :: String
effNameBase =
        if String
clsName forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. Snoc s s a a => Traversal' s a
_last forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
clsOrderSym
            then forall a. Int -> [a] -> [a]
dropEnd Int
1 String
clsName
            else String
clsName

-- | Symbol letters representing the order of the effect.
effectOrderSymbol :: EffectOrder -> (Char, Char)
effectOrderSymbol :: EffectOrder -> (Char, Char)
effectOrderSymbol = \case
    EffectOrder
FirstOrder -> (Char
'F', Char
'I')
    EffectOrder
HigherOrder -> (Char
'H', Char
'S')

-- ** Generating Synonyms about LiftIns

{- |
Generate the pattern synonyms for instruction constructors:

    @pattern BazS ... = LiftIns (Baz ...)@
-}
generateLiftInsPatternSynonyms :: Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms :: Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms Name
dataName EffectInfo
info = do
    [(Name, [Dec])]
patSyns <-
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [MethodInterface]
effMethods EffectInfo
info) \MethodInterface{[Type]
Type
Name
EffectOrder
methodCxt :: [Type]
methodReturnType :: Type
methodParamTypes :: [Type]
methodOrder :: EffectOrder
methodName :: Name
methodCxt :: MethodInterface -> [Type]
methodReturnType :: MethodInterface -> Type
methodParamTypes :: MethodInterface -> [Type]
methodOrder :: MethodInterface -> EffectOrder
methodName :: MethodInterface -> Name
..} -> do
            let conName :: Name
conName = Name -> Name
renameMethodToCon Name
methodName
                newConName :: Name
newConName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName forall a. [a] -> [a] -> [a]
++ String
"S"
            [Name]
args <- 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")
            Q Type
a <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
            (Name
newConName,)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                    [ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
patSynSigD
                        Name
newConName
                        -- For some reason, if I don't write constraints in this form, the type is
                        -- not inferred properly (why?).
                        [t|
                            () =>
                            ($a ~ $(pure methodReturnType)) =>
                            $( foldr
                                (\l r -> arrowT `appT` pure l `appT` r)
                                [t|
                                    $(liftInsType dataName $ tyVarName <$> effParamVars info)
                                        $(varT $ tyVarName $ effMonad info)
                                        $a
                                    |]
                                methodParamTypes
                             )
                            |]
                    , forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD
                        Name
newConName
                        (forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [Name]
args)
                        forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                        (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'LiftIns [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args])
                    ]

    (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Name, [Dec])]
patSyns ++)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *). Quote m => [Name] -> Maybe Name -> m Dec
pragCompleteD (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, [Dec])]
patSyns) forall a. Maybe a
Nothing]

{- |
Generate the type synonym for an instruction datatype:

    @type (FoobarS ...) = LiftIns (FoobarI ...)@
-}
generateLiftInsTypeSynonym :: EffectInfo -> Name -> Q Dec
generateLiftInsTypeSynonym :: EffectInfo -> Name -> Q Dec
generateLiftInsTypeSynonym EffectInfo
info Name
dataName = do
    Name
nameS <- String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q String
renameI2S (Name -> String
nameBase Name
dataName)
    forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD
        Name
nameS
        ([Name]
pvs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ()))
        (Name -> [Name] -> Q Type
liftInsType Name
dataName [Name]
pvs)
  where
    pvs :: [Name]
pvs = forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info

renameI2S :: String -> Q String
renameI2S :: String -> Q String
renameI2S String
name = String -> Q String
dropEndI String
name forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. [a] -> [a] -> [a]
++ String
"S")

dropEndI :: String -> Q String
dropEndI :: String -> Q String
dropEndI String
name =
    if String
name forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. Snoc s s a a => Traversal' s a
_last forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
'I'
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
dropEnd Int
1 String
name
        else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The name doesn't end in 'I': \"" forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
"\"."

liftInsType :: Name -> [Name] -> Q Type
liftInsType :: Name -> [Name] -> Q Type
liftInsType Name
dataName [Name]
pvs =
    forall (m :: * -> *). Quote m => Name -> m Type
conT ''LiftIns forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` 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
dataName) (forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
pvs)

applyEffPVs :: Name -> [Name] -> Q Type
applyEffPVs :: Name -> [Name] -> Q Type
applyEffPVs Name
effClsName = 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
effClsName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). Quote m => Name -> m Type
varT

-- ** Reification of Effect Class

-- | Information about effect type classes.
data EffectInfo = EffectInfo
    { EffectInfo -> [Type]
effCxts :: [Type]
    , EffectInfo -> Name
effName :: Name
    , EffectInfo -> [TyVarBndr ()]
effParamVars :: [TyVarBndr ()]
    , EffectInfo -> TyVarBndr ()
effMonad :: TyVarBndr ()
    , EffectInfo -> [MethodInterface]
effMethods :: [MethodInterface]
    }

effParamVar :: (Name, Maybe Kind) -> TyVarBndr ()
effParamVar :: (Name, Maybe Type) -> TyVarBndr ()
effParamVar (Name
n, Maybe Type
k) = case Maybe Type
k of
    Just Type
k' -> forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n () Type
k'
    Maybe Type
Nothing -> forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()

data MethodInterface = MethodInterface
    { MethodInterface -> Name
methodName :: Name
    , MethodInterface -> EffectOrder
methodOrder :: EffectOrder
    , MethodInterface -> [Type]
methodParamTypes :: [Type]
    , MethodInterface -> Type
methodReturnType :: Type
    , MethodInterface -> [Type]
methodCxt :: Cxt
    }

-- | Given a type class name, extracts infos about an effect.
reifyEffectInfo :: Name -> Q EffectInfo
reifyEffectInfo :: Name -> Q EffectInfo
reifyEffectInfo Name
className = do
    Info
info <- Name -> Q Info
reify Name
className
    case Info
info of
        ClassI (ClassD [Type]
cxts Name
name [TyVarBndr ()]
tyVars [FunDep]
_funDeps [Dec]
decs) [Dec]
_ -> do
            ([TyVarBndr ()]
paramVars, TyVarBndr ()
monad) <-
                case [TyVarBndr ()]
tyVars of
                    [] ->
                        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                            String
"The specified effect type class `"
                                forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
                                forall a. [a] -> [a] -> [a]
++ String
"' has no monad type variable. "
                                forall a. [a] -> [a] -> [a]
++ String
"It is expected to be the last type variable."
                    [TyVarBndr ()]
vs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
init [TyVarBndr ()]
vs, forall a. [a] -> a
last [TyVarBndr ()]
vs)

            [Type]
-> Name
-> [TyVarBndr ()]
-> TyVarBndr ()
-> [MethodInterface]
-> EffectInfo
EffectInfo [Type]
cxts Name
name [TyVarBndr ()]
paramVars TyVarBndr ()
monad
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                    [ do
                        (EffectOrder
order, [Type]
paramTypes, Type
retType, [Type]
cxt) <- TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, [Type])
analyzeMethodInterface TyVarBndr ()
monad Type
t
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> EffectOrder -> [Type] -> Type -> [Type] -> MethodInterface
MethodInterface Name
n EffectOrder
order [Type]
paramTypes Type
retType [Type]
cxt
                    | SigD Name
n Type
t <- [Dec]
decs
                    ]
        Info
other ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                String
"The specified name `"
                    forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className
                    forall a. [a] -> [a] -> [a]
++ String
"' is not a type class, but the following instead: "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Info
other

-- | Constructs the type of an effect, i.e. the type class without its monad parameter.
effectType :: EffectInfo -> Q Type
effectType :: EffectInfo -> Q Type
effectType EffectInfo
info =
    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 forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info)
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TyVarBndr a -> Q Type
tyVarType (EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info))

partitionSuperEffects :: EffectInfo -> (Cxt, [Type])
partitionSuperEffects :: EffectInfo -> ([Type], [Type])
partitionSuperEffects EffectInfo
info =
    ( forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Type
extract) [Type]
cxts
    , forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Type
extract (EffectInfo -> [Type]
effCxts EffectInfo
info)
    )
  where
    cxts :: [Type]
cxts = EffectInfo -> [Type]
effCxts EffectInfo
info
    m :: Name
m = forall a. TyVarBndr a -> Name
tyVarName (EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info)
    extract :: Type -> Maybe Type
extract = \case
        ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t -> Type -> Maybe Type
extract Type
t
        SigT Type
t Type
_ -> Type -> Maybe Type
extract Type
t
        ParensT Type
t -> Type -> Maybe Type
extract Type
t
        Type
t `AppT` VarT Name
n | Name
n forall a. Eq a => a -> a -> Bool
== Name
m -> forall a. a -> Maybe a
Just Type
t
        InfixT Type
t Name
_ (VarT Name
n) | Name
n forall a. Eq a => a -> a -> Bool
== Name
m -> forall a. a -> Maybe a
Just Type
t
        UInfixT Type
t Name
_ (VarT Name
n) | Name
n forall a. Eq a => a -> a -> Bool
== Name
m -> forall a. a -> Maybe a
Just Type
t
        AppKindT Type
t Type
_ -> Type -> Maybe Type
extract Type
t
        ImplicitParamT String
_ Type
t -> Type -> Maybe Type
extract Type
t
        Type
_ -> forall a. Maybe a
Nothing

{- |
Extracts the super classes of an effect which have the kind of effects. As an example, for the
following effect ...

@class (State s m, Monad m) => MyEffect s m where ...@

... this would pure [State s, Monad].
-}
superEffects :: EffectInfo -> [Type]
superEffects :: EffectInfo -> [Type]
superEffects = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> ([Type], [Type])
partitionSuperEffects

{- |
Like superEffects, but ignores super classes from base (i.e., Applicative, Functor, Monad, MonadIO).
-}
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase =
    forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isBase) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> [Type]
superEffects
  where
    isBase :: Type -> Bool
isBase = \case
        ConT Name
n -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [''Applicative, ''Functor, ''Monad, ''MonadIO]
        Type
_ -> Bool
False

effectParamCxt :: EffectInfo -> Cxt
effectParamCxt :: EffectInfo -> [Type]
effectParamCxt = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> ([Type], [Type])
partitionSuperEffects

-- ** Utility functions

-- | Construct a namer from a conversion function of string.
pureNamer :: (String -> String) -> Name -> Q Name
pureNamer :: (String -> String) -> Name -> Q Name
pureNamer String -> String
f = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | Throws away all kind information from a type.
unkindType :: Type -> Type
unkindType :: Type -> Type
unkindType = \case
    ForallT [TyVarBndr Specificity]
vs [Type]
ps Type
t -> [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar [TyVarBndr Specificity]
vs) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
unkindType [Type]
ps) (Type -> Type
unkindType Type
t)
    AppT Type
l Type
r -> Type -> Type -> Type
AppT (Type -> Type
unkindType Type
l) (Type -> Type
unkindType Type
r)
    SigT Type
t Type
_ -> Type
t
    InfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
InfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
    UInfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
UInfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
    ParensT Type
t -> Type -> Type
ParensT (Type -> Type
unkindType Type
t)
    AppKindT Type
t Type
_ -> Type -> Type
unkindType Type
t
    ImplicitParamT String
s Type
t -> String -> Type -> Type
ImplicitParamT String
s (Type -> Type
unkindType Type
t)
    Type
other -> Type
other

-- | Throws away the kind information of a type variable.
unkindTyVar :: TyVarBndr a -> TyVarBndr a
unkindTyVar :: forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar (KindedTV Name
n a
s Type
_) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n a
s
unkindTyVar TyVarBndr a
unkinded = TyVarBndr a
unkinded

-- | Converts a type variable to a type.
tyVarType :: TyVarBndr a -> Q Type
tyVarType :: forall a. TyVarBndr a -> Q Type
tyVarType (PlainTV Name
n a
_) = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
n
tyVarType (KindedTV Name
n a
_ Type
k) = forall (m :: * -> *). Quote m => m Type -> Type -> m Type
sigT (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
n) Type
k

tyVarKind :: TyVarBndr a -> Q Type
tyVarKind :: forall a. TyVarBndr a -> Q Type
tyVarKind (KindedTV Name
_ a
_ Type
k) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
k
tyVarKind (PlainTV Name
_ a
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The type variable has no kind."

-- | Counts the parameters of a type.
paramCount :: Type -> Int
paramCount :: Type -> Int
paramCount = \case
    Type
ArrowT `AppT` Type
_ `AppT` Type
r -> Int
1 forall a. Num a => a -> a -> a
+ Type -> Int
paramCount Type
r
    ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t -> Type -> Int
paramCount Type
t
    Type
_ -> Int
0

-- | Checks if a name m appears somewhere in a type.
occurs :: Name -> Type -> Bool
occurs :: Name -> Type -> Bool
occurs Name
m = \case
    ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
    AppT Type
l Type
r -> Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
    SigT Type
t Type
_ -> Name
m Name -> Type -> Bool
`occurs` Type
t
    VarT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
    ConT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
    PromotedT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
    InfixT Type
l Name
n Type
r -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
    UInfixT Type
l Name
n Type
r -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
    ParensT Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
    AppKindT Type
t Type
_ -> Name
m Name -> Type -> Bool
`occurs` Type
t
    ImplicitParamT String
_ Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
    Type
_ -> Bool
False