{-# 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 licensed under the BSD3 License as
    shown in [1]. The modified code, in its entirety, is licensed under
    MPL 2.0. When redistributing, please ensure that you do not remove
    the BSD3 License text as indicated in [1].
    <https://hackage.haskell.org/package/effet-0.4.0.0/docs/src/Control.Effect.Machinery.TH.html>

    [1] Copyright Michael Szvetits (c) 2020

        All rights reserved.

        Redistribution and use in source and binary forms, with or without
        modification, are permitted provided that the following conditions are met:

            * Redistributions of source code must retain the above copyright
            notice, this list of conditions and the following disclaimer.

            * Redistributions in binary form must reproduce the above
            copyright notice, this list of conditions and the following
            disclaimer in the documentation and/or other materials provided
            with the distribution.

            * Neither the name of Michael Szvetits nor the names of other
            contributors may be used to endorse or promote products derived
            from this software without specific prior written permission.

        THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
        "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
        LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
        A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
        OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
        SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
        LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
        DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
        THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
        (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
        OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}

{- |
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