{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- SPDX-License-Identifier: MPL-2.0 AND BSD-3-Clause

{- |
Copyright   :  (c) 2023-2025 Sayo contributors
               (c) 2010-2011 Patrick Bahr, Tom Hvitved
               (c) 2020 Michael Szvetits
License     :  MPL-2.0 (see the LICENSE file) AND BSD-3-Clause
Maintainer  :  ymdfield@outlook.jp
-}
module Data.Effect.TH.Internal where

import Control.Arrow ((>>>))
import Control.Effect (Eff, Free, perform, perform', perform'', send)
import Control.Lens (Traversal', makeLenses, (%~), (.~), _head)
import Control.Monad (forM, forM_, replicateM, when)
import Control.Monad.Reader (ReaderT, ask)
import Control.Monad.Writer.CPS (WriterT, execWriterT, lift, tell)
import Data.Char (toLower)
import Data.Default (Default, def)
import Data.Effect (EffectOrder (FirstOrder, HigherOrder), FirstOrder, LabelOf, OrderOf)
import Data.Effect.OpenUnion (Has, In, (:>))
import Data.Effect.Tag (Tagged)
import Data.Either.Extra (mapLeft, maybeToEither)
import Data.Either.Validation (Validation, eitherToValidation, validationToEither)
import Data.Function ((&))
import Data.Functor (($>), (<&>))
import Data.List (foldl', uncons)
import Data.List.Extra (unsnoc)
import Data.Maybe (fromJust, isJust)
import Data.Text qualified as T
import Language.Haskell.TH (
    BangType,
    Body (NormalB),
    Clause (Clause),
    Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC),
    Dec (DataD, FunD, NewtypeD, PragmaD),
    DocLoc (ArgDoc, DeclDoc),
    Exp (AppE, AppTypeE, ConE, SigE, VarE),
    Info (TyConI),
    Inline (Inline),
    Pat (VarP),
    Phases (AllPhases),
    Pragma (InlineP),
    RuleMatch (FunLike),
    Specificity (SpecifiedSpec),
    TyVarBndr (..),
    TyVarBndrSpec,
    Type,
    conT,
    getDoc,
    mkName,
    pprint,
    putDoc,
    varT,
 )
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax (
    Cxt,
    Dec (SigD),
    Name,
    Q,
    Quote (newName),
    Type (
        AppKindT,
        AppT,
        ArrowT,
        ConT,
        ForallT,
        ImplicitParamT,
        InfixT,
        ParensT,
        PromotedT,
        SigT,
        UInfixT,
        VarT
    ),
    addModFinalizer,
    nameBase,
    reify,
 )

data EffectInfo = EffectInfo
    { EffectInfo -> Name
eName :: Name
    , EffectInfo -> [TyVarBndr ()]
eParamVars :: [TyVarBndr ()]
    , EffectInfo -> TyVarBndr ()
eCarrier :: TyVarBndr ()
    , EffectInfo -> [OpInfo]
eOps :: [OpInfo]
    }

data OpInfo = OpInfo
    { OpInfo -> Name
opName :: Name
    , OpInfo -> [Type]
opParamTypes :: [TH.Type]
    , OpInfo -> Type
opDataType :: TH.Type
    , OpInfo -> Type
opResultType :: TH.Type
    , OpInfo -> [TyVarBndrSpec]
opTyVars :: [TyVarBndrSpec]
    , OpInfo -> TyVarBndr ()
opCarrier :: TyVarBndr ()
    , OpInfo -> [Type]
opCxt :: Cxt
    , OpInfo -> EffectOrder
opOrder :: EffectOrder
    }

data EffectConf = EffectConf
    { EffectConf -> Name -> OpConf
opConf :: Name -> OpConf
    , EffectConf -> Bool
doesGenerateLabel :: Bool
    , EffectConf -> Bool
doesGenerateOrderInstance :: Bool
    }

alterOpConf :: (OpConf -> OpConf) -> EffectConf -> EffectConf
alterOpConf :: (OpConf -> OpConf) -> EffectConf -> EffectConf
alterOpConf OpConf -> OpConf
f EffectConf
conf = EffectConf
conf{opConf = f . opConf conf}

data OpConf = OpConf
    { OpConf -> Maybe PerformerConf
_normalPerformerConf :: Maybe PerformerConf
    , OpConf -> Maybe PerformerConf
_keyedPerformerConf :: Maybe PerformerConf
    , OpConf -> Maybe PerformerConf
_taggedPerformerConf :: Maybe PerformerConf
    , OpConf -> Maybe PerformerConf
_senderConf :: Maybe PerformerConf
    }

data PerformerConf = PerformerConf
    { PerformerConf -> String
_performerName :: String
    , PerformerConf -> Bool
_doesGeneratePerformerSignature :: Bool
    , PerformerConf -> Maybe String -> Q (Maybe String)
_performerDoc :: Maybe String -> Q (Maybe String)
    , PerformerConf -> Int -> Maybe String -> Q (Maybe String)
_performerArgDoc :: Int -> Maybe String -> Q (Maybe String)
    }

performerConfs :: Traversal' OpConf PerformerConf
performerConfs :: Traversal' OpConf PerformerConf
performerConfs PerformerConf -> f PerformerConf
f OpConf{Maybe PerformerConf
_normalPerformerConf :: OpConf -> Maybe PerformerConf
_keyedPerformerConf :: OpConf -> Maybe PerformerConf
_taggedPerformerConf :: OpConf -> Maybe PerformerConf
_senderConf :: OpConf -> Maybe PerformerConf
_normalPerformerConf :: Maybe PerformerConf
_keyedPerformerConf :: Maybe PerformerConf
_taggedPerformerConf :: Maybe PerformerConf
_senderConf :: Maybe PerformerConf
..} = do
    Maybe PerformerConf
normal <- (PerformerConf -> f PerformerConf)
-> Maybe PerformerConf -> f (Maybe PerformerConf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse PerformerConf -> f PerformerConf
f Maybe PerformerConf
_normalPerformerConf
    Maybe PerformerConf
keyed <- (PerformerConf -> f PerformerConf)
-> Maybe PerformerConf -> f (Maybe PerformerConf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse PerformerConf -> f PerformerConf
f Maybe PerformerConf
_keyedPerformerConf
    Maybe PerformerConf
tagged <- (PerformerConf -> f PerformerConf)
-> Maybe PerformerConf -> f (Maybe PerformerConf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse PerformerConf -> f PerformerConf
f Maybe PerformerConf
_taggedPerformerConf
    Maybe PerformerConf
sender <- (PerformerConf -> f PerformerConf)
-> Maybe PerformerConf -> f (Maybe PerformerConf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse PerformerConf -> f PerformerConf
f Maybe PerformerConf
_senderConf
    pure
        OpConf
            { _normalPerformerConf :: Maybe PerformerConf
_normalPerformerConf = Maybe PerformerConf
normal
            , _keyedPerformerConf :: Maybe PerformerConf
_keyedPerformerConf = Maybe PerformerConf
keyed
            , _taggedPerformerConf :: Maybe PerformerConf
_taggedPerformerConf = Maybe PerformerConf
tagged
            , _senderConf :: Maybe PerformerConf
_senderConf = Maybe PerformerConf
sender
            }

makeLenses ''OpConf
makeLenses ''PerformerConf

noGenerateNormalPerformer :: EffectConf -> EffectConf
noGenerateNormalPerformer :: EffectConf -> EffectConf
noGenerateNormalPerformer = (OpConf -> OpConf) -> EffectConf -> EffectConf
alterOpConf ((OpConf -> OpConf) -> EffectConf -> EffectConf)
-> (OpConf -> OpConf) -> EffectConf -> EffectConf
forall a b. (a -> b) -> a -> b
$ (Maybe PerformerConf -> Identity (Maybe PerformerConf))
-> OpConf -> Identity OpConf
Lens' OpConf (Maybe PerformerConf)
normalPerformerConf ((Maybe PerformerConf -> Identity (Maybe PerformerConf))
 -> OpConf -> Identity OpConf)
-> Maybe PerformerConf -> OpConf -> OpConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe PerformerConf
forall a. Maybe a
Nothing
{-# INLINE noGenerateNormalPerformer #-}

noGenerateKeyedPerformer :: EffectConf -> EffectConf
noGenerateKeyedPerformer :: EffectConf -> EffectConf
noGenerateKeyedPerformer = (OpConf -> OpConf) -> EffectConf -> EffectConf
alterOpConf ((OpConf -> OpConf) -> EffectConf -> EffectConf)
-> (OpConf -> OpConf) -> EffectConf -> EffectConf
forall a b. (a -> b) -> a -> b
$ (Maybe PerformerConf -> Identity (Maybe PerformerConf))
-> OpConf -> Identity OpConf
Lens' OpConf (Maybe PerformerConf)
keyedPerformerConf ((Maybe PerformerConf -> Identity (Maybe PerformerConf))
 -> OpConf -> Identity OpConf)
-> Maybe PerformerConf -> OpConf -> OpConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe PerformerConf
forall a. Maybe a
Nothing
{-# INLINE noGenerateKeyedPerformer #-}

noGenerateTaggedPerformer :: EffectConf -> EffectConf
noGenerateTaggedPerformer :: EffectConf -> EffectConf
noGenerateTaggedPerformer = (OpConf -> OpConf) -> EffectConf -> EffectConf
alterOpConf ((OpConf -> OpConf) -> EffectConf -> EffectConf)
-> (OpConf -> OpConf) -> EffectConf -> EffectConf
forall a b. (a -> b) -> a -> b
$ (Maybe PerformerConf -> Identity (Maybe PerformerConf))
-> OpConf -> Identity OpConf
Lens' OpConf (Maybe PerformerConf)
taggedPerformerConf ((Maybe PerformerConf -> Identity (Maybe PerformerConf))
 -> OpConf -> Identity OpConf)
-> Maybe PerformerConf -> OpConf -> OpConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe PerformerConf
forall a. Maybe a
Nothing
{-# INLINE noGenerateTaggedPerformer #-}

noGeneratePerformerSignature :: EffectConf -> EffectConf
noGeneratePerformerSignature :: EffectConf -> EffectConf
noGeneratePerformerSignature =
    (OpConf -> OpConf) -> EffectConf -> EffectConf
alterOpConf ((OpConf -> OpConf) -> EffectConf -> EffectConf)
-> (OpConf -> OpConf) -> EffectConf -> EffectConf
forall a b. (a -> b) -> a -> b
$ (PerformerConf -> Identity PerformerConf)
-> OpConf -> Identity OpConf
Traversal' OpConf PerformerConf
performerConfs ((PerformerConf -> Identity PerformerConf)
 -> OpConf -> Identity OpConf)
-> (PerformerConf -> PerformerConf) -> OpConf -> OpConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Bool -> Identity Bool) -> PerformerConf -> Identity PerformerConf
Lens' PerformerConf Bool
doesGeneratePerformerSignature ((Bool -> Identity Bool)
 -> PerformerConf -> Identity PerformerConf)
-> Bool -> PerformerConf -> PerformerConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE noGeneratePerformerSignature #-}

noGenerateLabel :: EffectConf -> EffectConf
noGenerateLabel :: EffectConf -> EffectConf
noGenerateLabel EffectConf
conf = EffectConf
conf{doesGenerateLabel = False}
{-# INLINE noGenerateLabel #-}

noGenerateOrderInstance :: EffectConf -> EffectConf
noGenerateOrderInstance :: EffectConf -> EffectConf
noGenerateOrderInstance EffectConf
conf = EffectConf
conf{doesGenerateOrderInstance = False}
{-# INLINE noGenerateOrderInstance #-}

instance Default EffectConf where
    def :: EffectConf
def =
        EffectConf
            { opConf :: Name -> OpConf
opConf = \Name
opName ->
                let conf :: PerformerConf
conf =
                        PerformerConf
                            { _performerName :: String
_performerName =
                                let effConName' :: String
effConName' = Name -> String
nameBase Name
opName
                                    (Char
opNameInitial, String
opNameTail) = Maybe (Char, String) -> (Char, String)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Char, String) -> (Char, String))
-> Maybe (Char, String) -> (Char, String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Char, String)
forall a. [a] -> Maybe (a, [a])
uncons String
effConName'
                                 in if Char
opNameInitial Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
                                        then String
opNameTail
                                        else String
effConName' String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& (Char -> Identity Char) -> String -> Identity String
forall s a. Cons s s a a => Traversal' s a
Traversal' String Char
_head ((Char -> Identity Char) -> String -> Identity String)
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Char -> Char
toLower
                            , _doesGeneratePerformerSignature :: Bool
_doesGeneratePerformerSignature = Bool
True
                            , _performerDoc :: Maybe String -> Q (Maybe String)
_performerDoc = Maybe String -> Q (Maybe String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            , _performerArgDoc :: Int -> Maybe String -> Q (Maybe String)
_performerArgDoc = (Maybe String -> Q (Maybe String))
-> Int -> Maybe String -> Q (Maybe String)
forall a b. a -> b -> a
const Maybe String -> Q (Maybe String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            }
                 in OpConf
                        { _normalPerformerConf :: Maybe PerformerConf
_normalPerformerConf = PerformerConf -> Maybe PerformerConf
forall a. a -> Maybe a
Just PerformerConf
conf
                        , _keyedPerformerConf :: Maybe PerformerConf
_keyedPerformerConf =
                            PerformerConf -> Maybe PerformerConf
forall a. a -> Maybe a
Just (PerformerConf -> Maybe PerformerConf)
-> PerformerConf -> Maybe PerformerConf
forall a b. (a -> b) -> a -> b
$ PerformerConf
conf PerformerConf -> (PerformerConf -> PerformerConf) -> PerformerConf
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> PerformerConf -> Identity PerformerConf
Lens' PerformerConf String
performerName ((String -> Identity String)
 -> PerformerConf -> Identity PerformerConf)
-> (String -> String) -> PerformerConf -> PerformerConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
                        , _taggedPerformerConf :: Maybe PerformerConf
_taggedPerformerConf =
                            PerformerConf -> Maybe PerformerConf
forall a. a -> Maybe a
Just (PerformerConf -> Maybe PerformerConf)
-> PerformerConf -> Maybe PerformerConf
forall a b. (a -> b) -> a -> b
$ PerformerConf
conf PerformerConf -> (PerformerConf -> PerformerConf) -> PerformerConf
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> PerformerConf -> Identity PerformerConf
Lens' PerformerConf String
performerName ((String -> Identity String)
 -> PerformerConf -> Identity PerformerConf)
-> (String -> String) -> PerformerConf -> PerformerConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"''")
                        , _senderConf :: Maybe PerformerConf
_senderConf =
                            PerformerConf -> Maybe PerformerConf
forall a. a -> Maybe a
Just (PerformerConf -> Maybe PerformerConf)
-> PerformerConf -> Maybe PerformerConf
forall a b. (a -> b) -> a -> b
$ PerformerConf
conf PerformerConf -> (PerformerConf -> PerformerConf) -> PerformerConf
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> PerformerConf -> Identity PerformerConf
Lens' PerformerConf String
performerName ((String -> Identity String)
 -> PerformerConf -> Identity PerformerConf)
-> (String -> String) -> PerformerConf -> PerformerConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'_")
                        }
            , doesGenerateLabel :: Bool
doesGenerateLabel = Bool
True
            , doesGenerateOrderInstance :: Bool
doesGenerateOrderInstance = Bool
True
            }

type EffectGenerator =
    ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) ()

genEffect, genFOE, genHOE :: EffectGenerator
genEffect :: EffectGenerator
genEffect = do
    (EffectConf
conf, Name
_, Info
_, DataInfo
_, EffectInfo
eInfo) <- ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  (EffectConf, Name, Info, DataInfo, EffectInfo)
forall r (m :: * -> *). MonadReader r m => m r
ask
    EffectConf -> EffectInfo -> Q [Dec]
genPerformers EffectConf
conf EffectInfo
eInfo Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> (WriterT [Dec] Q [Dec]
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo)
         (WriterT [Dec] Q)
         [Dec])
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall a b. a -> (a -> b) -> b
& WriterT [Dec] Q [Dec]
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  [Dec]
-> ([Dec] -> EffectGenerator) -> EffectGenerator
forall a b.
ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) a
-> (a
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b)
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> EffectGenerator
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    EffectConf -> EffectInfo -> Q [Dec]
genLabel EffectConf
conf EffectInfo
eInfo Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> (WriterT [Dec] Q [Dec]
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo)
         (WriterT [Dec] Q)
         [Dec])
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall a b. a -> (a -> b) -> b
& WriterT [Dec] Q [Dec]
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  [Dec]
-> ([Dec] -> EffectGenerator) -> EffectGenerator
forall a b.
ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) a
-> (a
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b)
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> EffectGenerator
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
genFOE :: EffectGenerator
genFOE = do
    EffectGenerator
genEffect
    (EffectConf
conf, Name
_, Info
_, DataInfo
_, EffectInfo{[TyVarBndr ()]
[OpInfo]
Name
TyVarBndr ()
eName :: EffectInfo -> Name
eParamVars :: EffectInfo -> [TyVarBndr ()]
eCarrier :: EffectInfo -> TyVarBndr ()
eOps :: EffectInfo -> [OpInfo]
eName :: Name
eParamVars :: [TyVarBndr ()]
eCarrier :: TyVarBndr ()
eOps :: [OpInfo]
..}) <- ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  (EffectConf, Name, Info, DataInfo, EffectInfo)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let eData :: Type
eData = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
eName) ((TyVarBndr () -> Type) -> [TyVarBndr ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr () -> Name) -> TyVarBndr () -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName) [TyVarBndr ()]
eParamVars)
    Bool -> EffectGenerator -> EffectGenerator
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EffectConf -> Bool
doesGenerateOrderInstance EffectConf
conf) do
        [d|type instance OrderOf $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
eData) = 'FirstOrder|] Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> (WriterT [Dec] Q [Dec]
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo)
         (WriterT [Dec] Q)
         [Dec])
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall a b. a -> (a -> b) -> b
& WriterT [Dec] Q [Dec]
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  [Dec]
-> ([Dec] -> EffectGenerator) -> EffectGenerator
forall a b.
ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) a
-> (a
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b)
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> EffectGenerator
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
        [d|instance FirstOrder $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
eData)|] Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> (WriterT [Dec] Q [Dec]
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo)
         (WriterT [Dec] Q)
         [Dec])
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall a b. a -> (a -> b) -> b
& WriterT [Dec] Q [Dec]
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  [Dec]
-> ([Dec] -> EffectGenerator) -> EffectGenerator
forall a b.
ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) a
-> (a
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b)
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> EffectGenerator
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
genHOE :: EffectGenerator
genHOE = do
    EffectGenerator
genEffect
    (EffectConf
conf, Name
_, Info
_, DataInfo
_, EffectInfo{[TyVarBndr ()]
[OpInfo]
Name
TyVarBndr ()
eName :: EffectInfo -> Name
eParamVars :: EffectInfo -> [TyVarBndr ()]
eCarrier :: EffectInfo -> TyVarBndr ()
eOps :: EffectInfo -> [OpInfo]
eName :: Name
eParamVars :: [TyVarBndr ()]
eCarrier :: TyVarBndr ()
eOps :: [OpInfo]
..}) <- ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  (EffectConf, Name, Info, DataInfo, EffectInfo)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let eData :: Type
eData = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
eName) ((TyVarBndr () -> Type) -> [TyVarBndr ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr () -> Name) -> TyVarBndr () -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName) [TyVarBndr ()]
eParamVars)
    Bool -> EffectGenerator -> EffectGenerator
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EffectConf -> Bool
doesGenerateOrderInstance EffectConf
conf) do
        [d|type instance OrderOf $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
eData) = 'HigherOrder|] Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> (WriterT [Dec] Q [Dec]
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo)
         (WriterT [Dec] Q)
         [Dec])
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall a b. a -> (a -> b) -> b
& WriterT [Dec] Q [Dec]
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo)
     (WriterT [Dec] Q)
     [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo)
  (WriterT [Dec] Q)
  [Dec]
-> ([Dec] -> EffectGenerator) -> EffectGenerator
forall a b.
ReaderT
  (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) a
-> (a
    -> ReaderT
         (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b)
-> ReaderT
     (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> EffectGenerator
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell

genPerformers :: EffectConf -> EffectInfo -> Q [Dec]
genPerformers :: EffectConf -> EffectInfo -> Q [Dec]
genPerformers EffectConf{Bool
Name -> OpConf
opConf :: EffectConf -> Name -> OpConf
doesGenerateLabel :: EffectConf -> Bool
doesGenerateOrderInstance :: EffectConf -> Bool
opConf :: Name -> OpConf
doesGenerateLabel :: Bool
doesGenerateOrderInstance :: Bool
..} EffectInfo{[TyVarBndr ()]
[OpInfo]
Name
TyVarBndr ()
eName :: EffectInfo -> Name
eParamVars :: EffectInfo -> [TyVarBndr ()]
eCarrier :: EffectInfo -> TyVarBndr ()
eOps :: EffectInfo -> [OpInfo]
eName :: Name
eParamVars :: [TyVarBndr ()]
eCarrier :: TyVarBndr ()
eOps :: [OpInfo]
..} = do
    WriterT [Dec] Q [()] -> Q [Dec]
forall (m :: * -> *) w a.
(Monad m, Monoid w) =>
WriterT w m a -> m w
execWriterT (WriterT [Dec] Q [()] -> Q [Dec])
-> WriterT [Dec] Q [()] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [OpInfo] -> (OpInfo -> WriterT [Dec] Q ()) -> WriterT [Dec] Q [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [OpInfo]
eOps \con :: OpInfo
con@OpInfo{[Type]
[TyVarBndrSpec]
Type
Name
EffectOrder
TyVarBndr ()
opName :: OpInfo -> Name
opParamTypes :: OpInfo -> [Type]
opDataType :: OpInfo -> Type
opResultType :: OpInfo -> Type
opTyVars :: OpInfo -> [TyVarBndrSpec]
opCarrier :: OpInfo -> TyVarBndr ()
opCxt :: OpInfo -> [Type]
opOrder :: OpInfo -> EffectOrder
opName :: Name
opParamTypes :: [Type]
opDataType :: Type
opResultType :: Type
opTyVars :: [TyVarBndrSpec]
opCarrier :: TyVarBndr ()
opCxt :: [Type]
opOrder :: EffectOrder
..} -> do
        let OpConf{Maybe PerformerConf
_normalPerformerConf :: OpConf -> Maybe PerformerConf
_keyedPerformerConf :: OpConf -> Maybe PerformerConf
_taggedPerformerConf :: OpConf -> Maybe PerformerConf
_senderConf :: OpConf -> Maybe PerformerConf
_normalPerformerConf :: Maybe PerformerConf
_keyedPerformerConf :: Maybe PerformerConf
_taggedPerformerConf :: Maybe PerformerConf
_senderConf :: Maybe PerformerConf
..} = Name -> OpConf
opConf Name
opName

        Maybe PerformerConf
-> (PerformerConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PerformerConf
_normalPerformerConf (OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genNormalPerformer OpInfo
con)
        Maybe PerformerConf
-> (PerformerConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PerformerConf
_keyedPerformerConf (OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genKeyedPerformer OpInfo
con)
        Maybe PerformerConf
-> (PerformerConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PerformerConf
_taggedPerformerConf (OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genTaggedPerformer OpInfo
con)
        Maybe PerformerConf
-> (PerformerConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PerformerConf
_senderConf (OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genSender OpInfo
con)

genLabel :: EffectConf -> EffectInfo -> Q [Dec]
genLabel :: EffectConf -> EffectInfo -> Q [Dec]
genLabel EffectConf{Bool
Name -> OpConf
opConf :: EffectConf -> Name -> OpConf
doesGenerateLabel :: EffectConf -> Bool
doesGenerateOrderInstance :: EffectConf -> Bool
opConf :: Name -> OpConf
doesGenerateLabel :: Bool
doesGenerateOrderInstance :: Bool
..} EffectInfo{[TyVarBndr ()]
[OpInfo]
Name
TyVarBndr ()
eName :: EffectInfo -> Name
eParamVars :: EffectInfo -> [TyVarBndr ()]
eCarrier :: EffectInfo -> TyVarBndr ()
eOps :: EffectInfo -> [OpInfo]
eName :: Name
eParamVars :: [TyVarBndr ()]
eCarrier :: TyVarBndr ()
eOps :: [OpInfo]
..} =
    WriterT [Dec] Q () -> Q [Dec]
forall (m :: * -> *) w a.
(Monad m, Monoid w) =>
WriterT w m a -> m w
execWriterT (WriterT [Dec] Q () -> Q [Dec]) -> WriterT [Dec] Q () -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doesGenerateLabel do
        let labelData :: Name
labelData = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
eName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Label"
            eData :: Type
eData = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
eName) ((TyVarBndr () -> Type) -> [TyVarBndr ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr () -> Name) -> TyVarBndr () -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName) [TyVarBndr ()]
eParamVars)

        [[Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
labelData [] Maybe Type
forall a. Maybe a
Nothing [] []] [Dec] -> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b. a -> (a -> b) -> b
& [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
        [d|type instance LabelOf $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
eData) = $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
labelData)|] Q [Dec]
-> (Q [Dec] -> WriterT [Dec] Q [Dec]) -> WriterT [Dec] Q [Dec]
forall a b. a -> (a -> b) -> b
& Q [Dec] -> WriterT [Dec] Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift WriterT [Dec] Q [Dec]
-> ([Dec] -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall a b.
WriterT [Dec] Q a -> (a -> WriterT [Dec] Q b) -> WriterT [Dec] Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell

genNormalPerformer
    :: OpInfo
    -> PerformerConf
    -> WriterT [Dec] Q ()
genNormalPerformer :: OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genNormalPerformer =
    (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> WriterT [Dec] Q ()
genPerformer
        (Name -> Exp
VarE 'perform `AppE`)
        (\Type
opDataType Type
es -> Type -> Name -> Type -> Type
InfixT Type
opDataType ''(:>) Type
es)
        [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. a -> a
id

genKeyedPerformer
    :: OpInfo
    -> PerformerConf
    -> WriterT [Dec] Q ()
genKeyedPerformer :: OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genKeyedPerformer OpInfo
eff PerformerConf
conf = do
    Name
nKey <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"key" Q Name -> (Q Name -> WriterT [Dec] Q Name) -> WriterT [Dec] Q Name
forall a b. a -> (a -> b) -> b
& Q Name -> WriterT [Dec] Q Name
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    let key :: Type
key = Name -> Type
VarT Name
nKey

    (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> WriterT [Dec] Q ()
genPerformer
        (Name -> Exp
VarE 'perform' Exp -> Type -> Exp
`AppTypeE` Type
key `AppE`)
        ( \Type
opDataType Type
es ->
            Name -> Type
ConT ''Has Type -> Type -> Type
`AppT` Type
key Type -> Type -> Type
`AppT` Type
opDataType Type -> Type -> Type
`AppT` Type
es
        )
        (Name -> Specificity -> TyVarBndrSpec
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
nKey Specificity
SpecifiedSpec :)
        OpInfo
eff
        PerformerConf
conf

genTaggedPerformer
    :: OpInfo
    -> PerformerConf
    -> WriterT [Dec] Q ()
genTaggedPerformer :: OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genTaggedPerformer OpInfo
conf PerformerConf
eff = do
    Name
nTag <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tag" Q Name -> (Q Name -> WriterT [Dec] Q Name) -> WriterT [Dec] Q Name
forall a b. a -> (a -> b) -> b
& Q Name -> WriterT [Dec] Q Name
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    let tag :: Type
tag = Name -> Type
VarT Name
nTag

    (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> WriterT [Dec] Q ()
genPerformer
        (Name -> Exp
VarE 'perform'' Exp -> Type -> Exp
`AppTypeE` Type
tag `AppE`)
        ( \Type
opDataType Type
es ->
            Type -> Name -> Type -> Type
InfixT (Name -> Type
ConT ''Tagged Type -> Type -> Type
`AppT` Type
tag Type -> Type -> Type
`AppT` Type
opDataType) ''(:>) Type
es
        )
        (Name -> Specificity -> TyVarBndrSpec
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
nTag Specificity
SpecifiedSpec :)
        OpInfo
conf
        PerformerConf
eff

genSender
    :: OpInfo
    -> PerformerConf
    -> WriterT [Dec] Q ()
genSender :: OpInfo -> PerformerConf -> WriterT [Dec] Q ()
genSender =
    (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> WriterT [Dec] Q ()
genPerformer
        (Name -> Exp
VarE 'send `AppE`)
        (\Type
opDataType Type
es -> Type -> Name -> Type -> Type
InfixT Type
opDataType ''In Type
es)
        [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. a -> a
id

genPerformer
    :: (Exp -> Exp)
    -> (TH.Type -> TH.Type -> TH.Type)
    -> ([TyVarBndrSpec] -> [TyVarBndrSpec])
    -> OpInfo
    -> PerformerConf
    -> WriterT [Dec] Q ()
genPerformer :: (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> WriterT [Dec] Q ()
genPerformer Exp -> Exp
performer Type -> Type -> Type
performCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs con :: OpInfo
con@OpInfo{[Type]
[TyVarBndrSpec]
Type
Name
EffectOrder
TyVarBndr ()
opName :: OpInfo -> Name
opParamTypes :: OpInfo -> [Type]
opDataType :: OpInfo -> Type
opResultType :: OpInfo -> Type
opTyVars :: OpInfo -> [TyVarBndrSpec]
opCarrier :: OpInfo -> TyVarBndr ()
opCxt :: OpInfo -> [Type]
opOrder :: OpInfo -> EffectOrder
opName :: Name
opParamTypes :: [Type]
opDataType :: Type
opResultType :: Type
opTyVars :: [TyVarBndrSpec]
opCarrier :: TyVarBndr ()
opCxt :: [Type]
opOrder :: EffectOrder
..} conf :: PerformerConf
conf@PerformerConf{Bool
String
Int -> Maybe String -> Q (Maybe String)
Maybe String -> Q (Maybe String)
_performerName :: PerformerConf -> String
_doesGeneratePerformerSignature :: PerformerConf -> Bool
_performerDoc :: PerformerConf -> Maybe String -> Q (Maybe String)
_performerArgDoc :: PerformerConf -> Int -> Maybe String -> Q (Maybe String)
_performerName :: String
_doesGeneratePerformerSignature :: Bool
_performerDoc :: Maybe String -> Q (Maybe String)
_performerArgDoc :: Int -> Maybe String -> Q (Maybe String)
..} = do
    (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> (Type -> Q Clause)
-> WriterT [Dec] Q ()
genPerformerArmor Type -> Type -> Type
performCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs OpInfo
con PerformerConf
conf \Type
f -> do
        [Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
opParamTypes) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")

        let body :: Exp
body =
                Exp -> Exp
performer
                    ( (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
opName) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
args)
                        Exp -> (Exp -> Exp) -> Exp
forall a b. a -> (a -> b) -> b
& if Bool
_doesGeneratePerformerSignature
                            then (Exp -> Type -> Exp
`SigE` ((Type
opDataType Type -> Type -> Type
`AppT` Type
f) Type -> Type -> Type
`AppT` Type
opResultType))
                            else Exp -> Exp
forall a. a -> a
id
                    )

        Clause -> Q Clause
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
args) (Exp -> Body
NormalB Exp
body) []

genPerformerArmor
    :: (TH.Type -> TH.Type -> TH.Type)
    -> ([TyVarBndrSpec] -> [TyVarBndrSpec])
    -> OpInfo
    -> PerformerConf
    -> (Type -> Q Clause)
    -> WriterT [Dec] Q ()
genPerformerArmor :: (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> OpInfo
-> PerformerConf
-> (Type -> Q Clause)
-> WriterT [Dec] Q ()
genPerformerArmor Type -> Type -> Type
performCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs OpInfo{[Type]
[TyVarBndrSpec]
Type
Name
EffectOrder
TyVarBndr ()
opName :: OpInfo -> Name
opParamTypes :: OpInfo -> [Type]
opDataType :: OpInfo -> Type
opResultType :: OpInfo -> Type
opTyVars :: OpInfo -> [TyVarBndrSpec]
opCarrier :: OpInfo -> TyVarBndr ()
opCxt :: OpInfo -> [Type]
opOrder :: OpInfo -> EffectOrder
opName :: Name
opParamTypes :: [Type]
opDataType :: Type
opResultType :: Type
opTyVars :: [TyVarBndrSpec]
opCarrier :: TyVarBndr ()
opCxt :: [Type]
opOrder :: EffectOrder
..} PerformerConf{Bool
String
Int -> Maybe String -> Q (Maybe String)
Maybe String -> Q (Maybe String)
_performerName :: PerformerConf -> String
_doesGeneratePerformerSignature :: PerformerConf -> Bool
_performerDoc :: PerformerConf -> Maybe String -> Q (Maybe String)
_performerArgDoc :: PerformerConf -> Int -> Maybe String -> Q (Maybe String)
_performerName :: String
_doesGeneratePerformerSignature :: Bool
_performerDoc :: Maybe String -> Q (Maybe String)
_performerArgDoc :: Int -> Maybe String -> Q (Maybe String)
..} Type -> Q Clause
clause = do
    let carrier :: Type
carrier = TyVarBndr () -> Type
forall a. TyVarBndr a -> Type
tyVarType TyVarBndr ()
opCarrier

    Name
free <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"ff" Q Name -> (Q Name -> WriterT [Dec] Q Name) -> WriterT [Dec] Q Name
forall a b. a -> (a -> b) -> b
& Q Name -> WriterT [Dec] Q Name
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    Name
es <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"es" Q Name -> (Q Name -> WriterT [Dec] Q Name) -> WriterT [Dec] Q Name
forall a b. a -> (a -> b) -> b
& Q Name -> WriterT [Dec] Q Name
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    Name
c <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"c" Q Name -> (Q Name -> WriterT [Dec] Q Name) -> WriterT [Dec] Q Name
forall a b. a -> (a -> b) -> b
& Q Name -> WriterT [Dec] Q Name
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    Type
freeCxt <- [t|Free $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
c) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
free)|] Q Type -> (Q Type -> WriterT [Dec] Q Type) -> WriterT [Dec] Q Type
forall a b. a -> (a -> b) -> b
& Q Type -> WriterT [Dec] Q Type
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    Type
carrierCxt <- [t|$(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
carrier) ~ Eff $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
free) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
es)|] Q Type -> (Q Type -> WriterT [Dec] Q Type) -> WriterT [Dec] Q Type
forall a b. a -> (a -> b) -> b
& Q Type -> WriterT [Dec] Q Type
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

    let fnName :: Name
fnName = String -> Name
mkName String
_performerName

        funSig :: Dec
funSig =
            Name -> Type -> Dec
SigD
                Name
fnName
                ( [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT
                    ([TyVarBndrSpec]
opTyVars [TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr ()
opCarrier TyVarBndr () -> Specificity -> TyVarBndrSpec
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Specificity
SpecifiedSpec) TyVarBndrSpec -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. a -> [a] -> [a]
: (Name -> TyVarBndrSpec) -> [Name] -> [TyVarBndrSpec]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n () TyVarBndr () -> Specificity -> TyVarBndrSpec
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Specificity
SpecifiedSpec) [Name
es, Name
free, Name
c] [TyVarBndrSpec]
-> ([TyVarBndrSpec] -> [TyVarBndrSpec]) -> [TyVarBndrSpec]
forall a b. a -> (a -> b) -> b
& [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs)
                    (Type
freeCxt Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
carrierCxt Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> Type -> Type
performCxt Type
opDataType (Name -> Type
VarT Name
es) Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
opCxt)
                    ([Type] -> Type -> Type
forall (t :: * -> *). Foldable t => t Type -> Type -> Type
arrowChain [Type]
opParamTypes (Type
carrier Type -> Type -> Type
`AppT` Type
opResultType))
                )

        funInline :: Dec
funInline = Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
fnName Inline
Inline RuleMatch
FunLike Phases
AllPhases)

    Dec
funDef <- Name -> [Clause] -> Dec
FunD Name
fnName ([Clause] -> Dec)
-> WriterT [Dec] Q [Clause] -> WriterT [Dec] Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WriterT [Dec] Q Clause] -> WriterT [Dec] Q [Clause]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Type -> Q Clause
clause Type
carrier Q Clause
-> (Q Clause -> WriterT [Dec] Q Clause) -> WriterT [Dec] Q Clause
forall a b. a -> (a -> b) -> b
& Q Clause -> WriterT [Dec] Q Clause
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift]

    -- Put documents
    Q () -> WriterT [Dec] Q ()
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> WriterT [Dec] Q ()) -> Q () -> WriterT [Dec] Q ()
forall a b. (a -> b) -> a -> b
$ Q () -> Q ()
addModFinalizer do
        Maybe String
effDoc <- DocLoc -> Q (Maybe String)
getDoc (DocLoc -> Q (Maybe String)) -> DocLoc -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ Name -> DocLoc
DeclDoc Name
opName
        Maybe String -> Q (Maybe String)
_performerDoc Maybe String
effDoc Q (Maybe String) -> (Maybe String -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Q ()) -> Maybe String -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \String
doc -> do
            DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
fnName) String
doc

        [Int] -> (Int -> Q ()) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
opParamTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] \Int
i -> do
            Maybe String
argDoc <- DocLoc -> Q (Maybe String)
getDoc (DocLoc -> Q (Maybe String)) -> DocLoc -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ Name -> Int -> DocLoc
ArgDoc Name
opName Int
i
            Int -> Maybe String -> Q (Maybe String)
_performerArgDoc Int
i Maybe String
argDoc Q (Maybe String) -> (Maybe String -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Q ()) -> Maybe String -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \String
doc -> do
                DocLoc -> String -> Q ()
putDoc (Name -> Int -> DocLoc
ArgDoc Name
fnName Int
i) String
doc

    -- Append declerations
    Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesGeneratePerformerSignature (WriterT [Dec] Q () -> WriterT [Dec] Q ())
-> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall a b. (a -> b) -> a -> b
$ [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Dec
funSig]
    [Dec] -> WriterT [Dec] Q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Dec
funDef, Dec
funInline]

arrowChain :: (Foldable t) => t TH.Type -> TH.Type -> TH.Type
arrowChain :: forall (t :: * -> *). Foldable t => t Type -> Type -> Type
arrowChain = (Type -> t Type -> Type) -> t Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Type -> t Type -> Type) -> t Type -> Type -> Type)
-> (Type -> t Type -> Type) -> t Type -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> t Type -> Type
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr \Type
l Type
r -> Type
ArrowT Type -> Type -> Type
`AppT` Type
l Type -> Type -> Type
`AppT` Type
r

-- | A reified information of a datatype.
data DataInfo = DataInfo
    { DataInfo -> [Type]
dataCxt :: Cxt
    , DataInfo -> Name
dataName :: Name
    , DataInfo -> [TyVarBndr ()]
dataTyVars :: [TyVarBndr ()]
    , DataInfo -> [ConInfo]
dataCons :: [ConInfo]
    }

data ConInfo = ConInfo
    { ConInfo -> Name
conName :: Name
    , ConInfo -> [BangType]
conArgs :: [BangType]
    , ConInfo -> Maybe Type
conGadtReturnType :: Maybe TH.Type
    , ConInfo -> [TyVarBndrSpec]
conTyVars :: [TyVarBndrSpec]
    , ConInfo -> [Type]
conCxt :: Cxt
    }

reifyEffect :: Name -> Q (Info, DataInfo, EffectInfo)
reifyEffect :: Name -> Q (Info, DataInfo, EffectInfo)
reifyEffect Name
name = do
    Info
info <- Name -> Q Info
reify Name
name

    DataInfo
dataInfo <-
        Info -> Maybe DataInfo
analyzeData Info
info
            Maybe DataInfo -> (Maybe DataInfo -> Q DataInfo) -> Q DataInfo
forall a b. a -> (a -> b) -> b
& Q DataInfo
-> (DataInfo -> Q DataInfo) -> Maybe DataInfo -> Q DataInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q DataInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DataInfo) -> String -> Q DataInfo
forall a b. (a -> b) -> a -> b
$ String
"Not datatype: ‘" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
pprint Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"’") DataInfo -> Q DataInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    EffectInfo
effClsInfo <-
        DataInfo -> Either Text EffectInfo
analyzeEffect DataInfo
dataInfo
            Either Text EffectInfo
-> (Either Text EffectInfo -> Q EffectInfo) -> Q EffectInfo
forall a b. a -> (a -> b) -> b
& (Text -> Q EffectInfo)
-> (EffectInfo -> Q EffectInfo)
-> Either Text EffectInfo
-> Q EffectInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q EffectInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q EffectInfo)
-> (Text -> String) -> Text -> Q EffectInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) EffectInfo -> Q EffectInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    pure (Info
info, DataInfo
dataInfo, EffectInfo
effClsInfo)

analyzeEffect :: DataInfo -> Either T.Text EffectInfo
analyzeEffect :: DataInfo -> Either Text EffectInfo
analyzeEffect DataInfo{[Type]
[TyVarBndr ()]
[ConInfo]
Name
dataCxt :: DataInfo -> [Type]
dataName :: DataInfo -> Name
dataTyVars :: DataInfo -> [TyVarBndr ()]
dataCons :: DataInfo -> [ConInfo]
dataCxt :: [Type]
dataName :: Name
dataTyVars :: [TyVarBndr ()]
dataCons :: [ConInfo]
..} = do
    ([TyVarBndr ()]
initTyVars, TyVarBndr ()
resultType) <- [TyVarBndr ()] -> Maybe ([TyVarBndr ()], TyVarBndr ())
forall a. [a] -> Maybe ([a], a)
unsnoc [TyVarBndr ()]
dataTyVars Maybe ([TyVarBndr ()], TyVarBndr ())
-> (Maybe ([TyVarBndr ()], TyVarBndr ())
    -> Either Text ([TyVarBndr ()], TyVarBndr ()))
-> Either Text ([TyVarBndr ()], TyVarBndr ())
forall a b. a -> (a -> b) -> b
& Text
-> Maybe ([TyVarBndr ()], TyVarBndr ())
-> Either Text ([TyVarBndr ()], TyVarBndr ())
forall a b. a -> Maybe b -> Either a b
maybeToEither Text
"No result type variable."
    ([TyVarBndr ()]
paramVars, TyVarBndr ()
carrier) <- [TyVarBndr ()] -> Maybe ([TyVarBndr ()], TyVarBndr ())
forall a. [a] -> Maybe ([a], a)
unsnoc [TyVarBndr ()]
initTyVars Maybe ([TyVarBndr ()], TyVarBndr ())
-> (Maybe ([TyVarBndr ()], TyVarBndr ())
    -> Either Text ([TyVarBndr ()], TyVarBndr ()))
-> Either Text ([TyVarBndr ()], TyVarBndr ())
forall a b. a -> (a -> b) -> b
& Text
-> Maybe ([TyVarBndr ()], TyVarBndr ())
-> Either Text ([TyVarBndr ()], TyVarBndr ())
forall a b. a -> Maybe b -> Either a b
maybeToEither Text
"No carrier type variable."

    let analyzeOp :: ConInfo -> Validation [T.Text] OpInfo
        analyzeOp :: ConInfo -> Validation [Text] OpInfo
analyzeOp ConInfo{[Type]
[BangType]
[TyVarBndrSpec]
Maybe Type
Name
conName :: ConInfo -> Name
conArgs :: ConInfo -> [BangType]
conGadtReturnType :: ConInfo -> Maybe Type
conTyVars :: ConInfo -> [TyVarBndrSpec]
conCxt :: ConInfo -> [Type]
conName :: Name
conArgs :: [BangType]
conGadtReturnType :: Maybe Type
conTyVars :: [TyVarBndrSpec]
conCxt :: [Type]
..} = Either [Text] OpInfo -> Validation [Text] OpInfo
forall e a. Either e a -> Validation e a
eitherToValidation do
            (Type
opDataType, TyVarBndr ()
opCarrier, Type
opResultType) <-
                Either [Text] (Type, TyVarBndr (), Type)
-> (Type -> Either [Text] (Type, TyVarBndr (), Type))
-> Maybe Type
-> Either [Text] (Type, TyVarBndr (), Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    ( (Type, TyVarBndr (), Type)
-> Either [Text] (Type, TyVarBndr (), Type)
forall a. a -> Either [Text] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        ( (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
VarT Name
dataName) ((TyVarBndr () -> Type) -> [TyVarBndr ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Type
forall a. TyVarBndr a -> Type
tyVarType [TyVarBndr ()]
paramVars)
                        , TyVarBndr ()
carrier
                        , TyVarBndr () -> Type
forall a. TyVarBndr a -> Type
tyVarType TyVarBndr ()
resultType
                        )
                    )
                    Type -> Either [Text] (Type, TyVarBndr (), Type)
decomposeGadtReturnType
                    Maybe Type
conGadtReturnType

            let removeCarrierTV :: [TyVarBndr a] -> [TyVarBndr a]
                removeCarrierTV :: forall a. [TyVarBndr a] -> [TyVarBndr a]
removeCarrierTV = (TyVarBndr a -> Bool) -> [TyVarBndr a] -> [TyVarBndr a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
opCarrier /=) (Name -> Bool) -> (TyVarBndr a -> Name) -> TyVarBndr a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr a -> Name
forall a. TyVarBndr a -> Name
tyVarName)

                opTyVars :: [TyVarBndrSpec]
opTyVars =
                    if Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
conGadtReturnType
                        then [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [TyVarBndr a] -> [TyVarBndr a]
removeCarrierTV [TyVarBndrSpec]
conTyVars
                        else (TyVarBndr () -> TyVarBndrSpec)
-> [TyVarBndr ()] -> [TyVarBndrSpec]
forall a b. (a -> b) -> [a] -> [b]
map (Specificity
SpecifiedSpec <$) ([TyVarBndr ()] -> [TyVarBndr ()]
forall a. [TyVarBndr a] -> [TyVarBndr a]
removeCarrierTV [TyVarBndr ()]
paramVars) [TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrSpec]
conTyVars

                opParamTypes :: [Type]
opParamTypes = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
conArgs

            OpInfo -> Either [Text] OpInfo
forall a b. b -> Either a b
Right
                OpInfo
                    { opName :: Name
opName = Name
conName
                    , opParamTypes :: [Type]
opParamTypes = [Type]
opParamTypes
                    , opDataType :: Type
opDataType = Type
opDataType
                    , opResultType :: Type
opResultType = Type
opResultType
                    , opTyVars :: [TyVarBndrSpec]
opTyVars = [TyVarBndrSpec]
opTyVars
                    , opCarrier :: TyVarBndr ()
opCarrier = TyVarBndr ()
opCarrier
                    , opCxt :: [Type]
opCxt = [Type]
conCxt
                    , opOrder :: EffectOrder
opOrder =
                        if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
opCarrier `occurs`) [Type]
opParamTypes
                            then EffectOrder
HigherOrder
                            else EffectOrder
FirstOrder
                    }
          where
            decomposeGadtReturnType
                :: TH.Type -> Either [T.Text] (TH.Type, TyVarBndr (), TH.Type)
            decomposeGadtReturnType :: Type -> Either [Text] (Type, TyVarBndr (), Type)
decomposeGadtReturnType =
                Type -> Type
unkindType (Type -> Type)
-> (Type -> Either [Text] (Type, TyVarBndr (), Type))
-> Type
-> Either [Text] (Type, TyVarBndr (), Type)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
                    Type
e `AppT` SigT (VarT Name
f) Type
kf `AppT` Type
x ->
                        (Type, TyVarBndr (), Type)
-> Either [Text] (Type, TyVarBndr (), Type)
forall a b. b -> Either a b
Right (Type
e, Name -> () -> Type -> TyVarBndr ()
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
f () Type
kf, Type
x)
                    Type
e `AppT` VarT Name
f `AppT` Type
x ->
                        (Type, TyVarBndr (), Type)
-> Either [Text] (Type, TyVarBndr (), Type)
forall a b. b -> Either a b
Right (Type
e, Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
f (), Type
x)
                    Type
t ->
                        [Text] -> Either [Text] (Type, TyVarBndr (), Type)
forall a b. a -> Either a b
Left
                            [ Text
"Unexpected form of GADT return type for the higher-order operation ‘"
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Name -> String
nameBase Name
conName)
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"’: "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Type -> String
forall a. Ppr a => a -> String
pprint Type
t)
                            ]

    [OpInfo]
effCons <-
        (ConInfo -> Validation [Text] OpInfo)
-> [ConInfo] -> Validation [Text] [OpInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ConInfo -> Validation [Text] OpInfo
analyzeOp [ConInfo]
dataCons
            Validation [Text] [OpInfo]
-> (Validation [Text] [OpInfo] -> Either [Text] [OpInfo])
-> Either [Text] [OpInfo]
forall a b. a -> (a -> b) -> b
& Validation [Text] [OpInfo] -> Either [Text] [OpInfo]
forall e a. Validation e a -> Either e a
validationToEither
            Either [Text] [OpInfo]
-> (Either [Text] [OpInfo] -> Either Text [OpInfo])
-> Either Text [OpInfo]
forall a b. a -> (a -> b) -> b
& ([Text] -> Text) -> Either [Text] [OpInfo] -> Either Text [OpInfo]
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft [Text] -> Text
T.unlines

    pure
        EffectInfo
            { eName :: Name
eName = Name
dataName
            , eParamVars :: [TyVarBndr ()]
eParamVars = [TyVarBndr ()]
paramVars
            , eCarrier :: TyVarBndr ()
eCarrier = TyVarBndr ()
carrier
            , eOps :: [OpInfo]
eOps = [OpInfo]
effCons
            }

-- * Utility functions

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

-- | Pures the name of a type variable.
tyVarName :: TyVarBndr a -> Name
tyVarName :: forall a. TyVarBndr a -> Name
tyVarName (PlainTV Name
n a
_) = Name
n
tyVarName (KindedTV Name
n a
_ Type
_) = Name
n

-- | Converts a type variable to a type.
tyVarType :: TyVarBndr a -> TH.Type
tyVarType :: forall a. TyVarBndr a -> Type
tyVarType (PlainTV Name
n a
_) = Name -> Type
VarT Name
n
tyVarType (KindedTV Name
n a
_ Type
k) = Type -> Type -> Type
SigT (Name -> Type
VarT Name
n) Type
k

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

unkindType :: TH.Type -> TH.Type
unkindType :: Type -> Type
unkindType = \case
    SigT Type
t Type
_ -> 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
_) = Name -> a -> TyVarBndr a
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n a
s
unkindTyVar TyVarBndr a
unkinded = TyVarBndr a
unkinded

-- | Checks if a name m appears somewhere in a type.
occurs :: Name -> TH.Type -> Bool
occurs :: Name -> Type -> Bool
occurs Name
m = \case
    ForallT [TyVarBndrSpec]
_ [Type]
cxt Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name
m `occurs`) [Type]
cxt
    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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
    ConT Name
n -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
    PromotedT Name
n -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
    InfixT Type
l Name
n Type
r -> Name
n Name -> Name -> Bool
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 Name -> Name -> Bool
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

{-  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 [2].
    <https://github.com/pa-ba/compdata/blob/master/src/Data/Comp/Derive/Utils.hs>

    [2] Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved

        All rights reserved.

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

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

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

        3. Neither the name of the author nor the names of his contributors
        may be used to endorse or promote products derived from this software
        without specific prior written permission.

        THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
-}

{- |
This function abstracts away @newtype@ declaration, it turns them into
@data@ declarations.
-}
analyzeData :: Info -> Maybe DataInfo
analyzeData :: Info -> Maybe DataInfo
analyzeData = \case
    TyConI (NewtypeD [Type]
cxt Name
name [TyVarBndr BndrVis]
args Maybe Type
_ Con
constr [DerivClause]
_) ->
        DataInfo -> Maybe DataInfo
forall a. a -> Maybe a
Just (DataInfo -> Maybe DataInfo) -> DataInfo -> Maybe DataInfo
forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [TyVarBndr ()] -> [ConInfo] -> DataInfo
DataInfo [Type]
cxt Name
name ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarBndr BndrVis -> () -> TyVarBndr ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) [TyVarBndr BndrVis]
args) (Con -> [ConInfo]
normalizeCon Con
constr)
    TyConI (DataD [Type]
cxt Name
name [TyVarBndr BndrVis]
args Maybe Type
_ [Con]
constrs [DerivClause]
_) ->
        DataInfo -> Maybe DataInfo
forall a. a -> Maybe a
Just (DataInfo -> Maybe DataInfo) -> DataInfo -> Maybe DataInfo
forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [TyVarBndr ()] -> [ConInfo] -> DataInfo
DataInfo [Type]
cxt Name
name ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarBndr BndrVis -> () -> TyVarBndr ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) [TyVarBndr BndrVis]
args) ((Con -> [ConInfo]) -> [Con] -> [ConInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [ConInfo]
normalizeCon [Con]
constrs)
    Info
_ -> Maybe DataInfo
forall a. Maybe a
Nothing

normalizeCon :: Con -> [ConInfo]
normalizeCon :: Con -> [ConInfo]
normalizeCon = \case
    ForallC [TyVarBndrSpec]
vars [Type]
cxt Con
constr ->
        [ConInfo
con{conTyVars = vars, conCxt = cxt} | ConInfo
con <- Con -> [ConInfo]
normalizeNonForallCon Con
constr]
    Con
con -> Con -> [ConInfo]
normalizeNonForallCon Con
con

normalizeNonForallCon :: Con -> [ConInfo]
normalizeNonForallCon :: Con -> [ConInfo]
normalizeNonForallCon = \case
    NormalC Name
constr [BangType]
args -> [Name
-> [BangType] -> Maybe Type -> [TyVarBndrSpec] -> [Type] -> ConInfo
ConInfo Name
constr [BangType]
args Maybe Type
forall a. Maybe a
Nothing [] []]
    RecC Name
constr [VarBangType]
args -> [Name
-> [BangType] -> Maybe Type -> [TyVarBndrSpec] -> [Type] -> ConInfo
ConInfo Name
constr ([VarBangType]
args [VarBangType] -> (VarBangType -> BangType) -> [BangType]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
_, Bang
s, Type
t) -> (Bang
s, Type
t)) Maybe Type
forall a. Maybe a
Nothing [] []]
    InfixC BangType
a Name
constr BangType
b -> [Name
-> [BangType] -> Maybe Type -> [TyVarBndrSpec] -> [Type] -> ConInfo
ConInfo Name
constr [BangType
a, BangType
b] Maybe Type
forall a. Maybe a
Nothing [] []]
    GadtC [Name]
cons [BangType]
args Type
typ -> [Name
-> [BangType] -> Maybe Type -> [TyVarBndrSpec] -> [Type] -> ConInfo
ConInfo Name
con [BangType]
args (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ) [] [] | Name
con <- [Name]
cons]
    RecGadtC [Name]
cons [VarBangType]
args Type
typ ->
        [Name
-> [BangType] -> Maybe Type -> [TyVarBndrSpec] -> [Type] -> ConInfo
ConInfo Name
con ([VarBangType]
args [VarBangType] -> (VarBangType -> BangType) -> [BangType]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
_, Bang
s, Type
t) -> (Bang
s, Type
t)) (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ) [] [] | Name
con <- [Name]
cons]
    ForallC{} -> String -> [ConInfo]
forall a. String -> [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected nested forall."