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

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2023-2024 Sayo Koyoneda
               (c) 2010-2011 Patrick Bahr, Tom Hvitved
               (c) 2020 Michael Szvetits
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable
-}
module Data.Effect.TH.Internal where

import Control.Lens (Traversal', makeLenses, (%~), (.~), _head)
import Control.Monad (forM, forM_, replicateM, unless, when)
import Data.List (foldl')
import Language.Haskell.TH.Syntax (
    Con,
    Cxt,
    Dec (SigD),
    Info,
    Name,
    Q,
    Quote (newName),
    TyVarBndr,
    Type (
        AppKindT,
        AppT,
        ArrowT,
        ConT,
        ForallT,
        ImplicitParamT,
        InfixT,
        ParensT,
        PromotedT,
        SigT,
        UInfixT,
        VarT
    ),
    addModFinalizer,
    nameBase,
    reify,
 )

import Control.Arrow ((>>>))
import Control.Effect (SendFOE, SendHOE, sendFOE, sendHOE)
import Control.Effect.Key (SendFOEBy, SendHOEBy, sendFOEBy, sendHOEBy)
import Control.Monad.Writer (WriterT, execWriterT, lift, tell)
import Data.Char (toLower)
import Data.Default (Default, def)
import Data.Effect (LiftFOE (LiftFOE))
import Data.Effect.Tag (Tag (Tag), TagH (TagH))
import Data.Either.Extra (mapLeft, maybeToEither)
import Data.Either.Validation (Validation, eitherToValidation, validationToEither)
import Data.Function ((&))
import Data.Functor (($>), (<&>))
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, PatSynD, PragmaD, TySynD),
    DocLoc (ArgDoc, DeclDoc),
    Exp (AppE, AppTypeE, ConE, SigE, VarE),
    Info (TyConI),
    Inline (Inline),
    Pat (ConP, VarP),
    PatSynArgs (PrefixPatSyn),
    PatSynDir (ImplBidir),
    Phases (AllPhases),
    Pragma (CompleteP, InlineP),
    RuleMatch (FunLike),
    Specificity (SpecifiedSpec),
    TyVarBndr (..),
    TyVarBndrSpec,
    Type (TupleT, WildCardT),
    getDoc,
    mkName,
    patSynSigD,
    pprint,
    putDoc,
    reportWarning,
 )
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Datatype.TyVarBndr (pattern BndrReq)

data EffClsInfo = EffClsInfo
    { EffClsInfo -> Name
ecName :: Name
    , EffClsInfo -> [TyVarBndr ()]
ecParamVars :: [TyVarBndr ()]
    , EffClsInfo -> Maybe (TyVarBndr ())
ecCarrier :: Maybe (TyVarBndr ())
    , EffClsInfo -> [EffConInfo]
ecEffs :: [EffConInfo]
    }

data EffConInfo = EffConInfo
    { EffConInfo -> Name
effName :: Name
    , EffConInfo -> [Type]
effParamTypes :: [TH.Type]
    , EffConInfo -> Type
effDataType :: TH.Type
    , EffConInfo -> Type
effResultType :: TH.Type
    , EffConInfo -> [TyVarBndrSpec]
effTyVars :: [TyVarBndrSpec]
    , EffConInfo -> Maybe (TyVarBndr ())
effCarrier :: Maybe (TyVarBndr ())
    , EffConInfo -> [Type]
effCxt :: Cxt
    }

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

orderOf :: EffClsInfo -> EffectOrder
orderOf :: EffClsInfo -> EffectOrder
orderOf =
    EffClsInfo -> Maybe (TyVarBndr ())
ecCarrier (EffClsInfo -> Maybe (TyVarBndr ()))
-> (Maybe (TyVarBndr ()) -> EffectOrder)
-> EffClsInfo
-> EffectOrder
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
        Just TyVarBndr ()
_ -> EffectOrder
HigherOrder
        Maybe (TyVarBndr ())
Nothing -> EffectOrder
FirstOrder

newtype MakeEffectConf = MakeEffectConf {MakeEffectConf -> EffClsInfo -> Q EffectClassConf
unMakeEffectConf :: EffClsInfo -> Q EffectClassConf}

alterEffectClassConf :: (EffectClassConf -> EffectClassConf) -> MakeEffectConf -> MakeEffectConf
alterEffectClassConf :: (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf EffectClassConf -> EffectClassConf
f (MakeEffectConf EffClsInfo -> Q EffectClassConf
conf) = (EffClsInfo -> Q EffectClassConf) -> MakeEffectConf
MakeEffectConf ((EffectClassConf -> EffectClassConf)
-> Q EffectClassConf -> Q EffectClassConf
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EffectClassConf -> EffectClassConf
f (Q EffectClassConf -> Q EffectClassConf)
-> (EffClsInfo -> Q EffectClassConf)
-> EffClsInfo
-> Q EffectClassConf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffClsInfo -> Q EffectClassConf
conf)
{-# INLINE alterEffectClassConf #-}

alterEffectConf :: (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf :: (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf EffectConf -> EffectConf
f = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf \EffectClassConf
conf ->
    EffectClassConf
conf{_confByEffect = f . _confByEffect conf}

data EffectClassConf = EffectClassConf
    { EffectClassConf -> Name -> EffectConf
_confByEffect :: Name -> EffectConf
    , EffectClassConf -> Bool
_doesDeriveHFunctor :: Bool
    , EffectClassConf -> Bool
_doesGenerateLiftFOETypeSynonym :: Bool
    , EffectClassConf -> Bool
_doesGenerateLiftFOEPatternSynonyms :: Bool
    }

data EffectConf = EffectConf
    { EffectConf -> Maybe SenderFunctionConf
_normalSenderGenConf :: Maybe SenderFunctionConf
    , EffectConf -> Maybe SenderFunctionConf
_taggedSenderGenConf :: Maybe SenderFunctionConf
    , EffectConf -> Maybe SenderFunctionConf
_keyedSenderGenConf :: Maybe SenderFunctionConf
    , EffectConf -> Bool
_warnFirstOrderInHOE :: Bool
    }

data SenderFunctionConf = SenderFunctionConf
    { SenderFunctionConf -> String
_senderFnName :: String
    , SenderFunctionConf -> Bool
_doesGenerateSenderFnSignature :: Bool
    , SenderFunctionConf -> Maybe String -> Q (Maybe String)
_senderFnDoc :: Maybe String -> Q (Maybe String)
    , SenderFunctionConf -> Int -> Maybe String -> Q (Maybe String)
_senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)
    }

senderFnConfs :: Traversal' EffectConf SenderFunctionConf
senderFnConfs :: Traversal' EffectConf SenderFunctionConf
senderFnConfs SenderFunctionConf -> f SenderFunctionConf
f EffectConf{Bool
Maybe SenderFunctionConf
_normalSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_taggedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_keyedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_warnFirstOrderInHOE :: EffectConf -> Bool
_normalSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf :: Maybe SenderFunctionConf
_keyedSenderGenConf :: Maybe SenderFunctionConf
_warnFirstOrderInHOE :: Bool
..} = do
    Maybe SenderFunctionConf
normal <- (SenderFunctionConf -> f SenderFunctionConf)
-> Maybe SenderFunctionConf -> f (Maybe SenderFunctionConf)
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 SenderFunctionConf -> f SenderFunctionConf
f Maybe SenderFunctionConf
_normalSenderGenConf
    Maybe SenderFunctionConf
tagged <- (SenderFunctionConf -> f SenderFunctionConf)
-> Maybe SenderFunctionConf -> f (Maybe SenderFunctionConf)
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 SenderFunctionConf -> f SenderFunctionConf
f Maybe SenderFunctionConf
_taggedSenderGenConf
    Maybe SenderFunctionConf
keyed <- (SenderFunctionConf -> f SenderFunctionConf)
-> Maybe SenderFunctionConf -> f (Maybe SenderFunctionConf)
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 SenderFunctionConf -> f SenderFunctionConf
f Maybe SenderFunctionConf
_keyedSenderGenConf
    pure
        EffectConf
            { _normalSenderGenConf :: Maybe SenderFunctionConf
_normalSenderGenConf = Maybe SenderFunctionConf
normal
            , _taggedSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf = Maybe SenderFunctionConf
tagged
            , _keyedSenderGenConf :: Maybe SenderFunctionConf
_keyedSenderGenConf = Maybe SenderFunctionConf
keyed
            , Bool
_warnFirstOrderInHOE :: Bool
_warnFirstOrderInHOE :: Bool
_warnFirstOrderInHOE
            }

makeLenses ''EffectClassConf
makeLenses ''EffectConf
makeLenses ''SenderFunctionConf

deriveHFunctor :: MakeEffectConf -> MakeEffectConf
deriveHFunctor :: MakeEffectConf -> MakeEffectConf
deriveHFunctor = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf ((EffectClassConf -> EffectClassConf)
 -> MakeEffectConf -> MakeEffectConf)
-> (EffectClassConf -> EffectClassConf)
-> MakeEffectConf
-> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool)
-> EffectClassConf -> Identity EffectClassConf
Lens' EffectClassConf Bool
doesDeriveHFunctor ((Bool -> Identity Bool)
 -> EffectClassConf -> Identity EffectClassConf)
-> Bool -> EffectClassConf -> EffectClassConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
{-# INLINE deriveHFunctor #-}

noDeriveHFunctor :: MakeEffectConf -> MakeEffectConf
noDeriveHFunctor :: MakeEffectConf -> MakeEffectConf
noDeriveHFunctor = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf ((EffectClassConf -> EffectClassConf)
 -> MakeEffectConf -> MakeEffectConf)
-> (EffectClassConf -> EffectClassConf)
-> MakeEffectConf
-> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool)
-> EffectClassConf -> Identity EffectClassConf
Lens' EffectClassConf Bool
doesDeriveHFunctor ((Bool -> Identity Bool)
 -> EffectClassConf -> Identity EffectClassConf)
-> Bool -> EffectClassConf -> EffectClassConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE noDeriveHFunctor #-}

generateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf
generateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf
generateLiftFOETypeSynonym = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf ((EffectClassConf -> EffectClassConf)
 -> MakeEffectConf -> MakeEffectConf)
-> (EffectClassConf -> EffectClassConf)
-> MakeEffectConf
-> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool)
-> EffectClassConf -> Identity EffectClassConf
Lens' EffectClassConf Bool
doesGenerateLiftFOETypeSynonym ((Bool -> Identity Bool)
 -> EffectClassConf -> Identity EffectClassConf)
-> Bool -> EffectClassConf -> EffectClassConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
{-# INLINE generateLiftFOETypeSynonym #-}

noGenerateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf
noGenerateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf
noGenerateLiftFOETypeSynonym = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf ((EffectClassConf -> EffectClassConf)
 -> MakeEffectConf -> MakeEffectConf)
-> (EffectClassConf -> EffectClassConf)
-> MakeEffectConf
-> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool)
-> EffectClassConf -> Identity EffectClassConf
Lens' EffectClassConf Bool
doesGenerateLiftFOETypeSynonym ((Bool -> Identity Bool)
 -> EffectClassConf -> Identity EffectClassConf)
-> Bool -> EffectClassConf -> EffectClassConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE noGenerateLiftFOETypeSynonym #-}

generateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf
generateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf
generateLiftFOEPatternSynonyms = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf ((EffectClassConf -> EffectClassConf)
 -> MakeEffectConf -> MakeEffectConf)
-> (EffectClassConf -> EffectClassConf)
-> MakeEffectConf
-> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool)
-> EffectClassConf -> Identity EffectClassConf
Lens' EffectClassConf Bool
doesGenerateLiftFOEPatternSynonyms ((Bool -> Identity Bool)
 -> EffectClassConf -> Identity EffectClassConf)
-> Bool -> EffectClassConf -> EffectClassConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
{-# INLINE generateLiftFOEPatternSynonyms #-}

noGenerateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf
noGenerateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf
noGenerateLiftFOEPatternSynonyms =
    (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf ((EffectClassConf -> EffectClassConf)
 -> MakeEffectConf -> MakeEffectConf)
-> (EffectClassConf -> EffectClassConf)
-> MakeEffectConf
-> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool)
-> EffectClassConf -> Identity EffectClassConf
Lens' EffectClassConf Bool
doesGenerateLiftFOEPatternSynonyms ((Bool -> Identity Bool)
 -> EffectClassConf -> Identity EffectClassConf)
-> Bool -> EffectClassConf -> EffectClassConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE noGenerateLiftFOEPatternSynonyms #-}

noGenerateNormalSenderFunction :: MakeEffectConf -> MakeEffectConf
noGenerateNormalSenderFunction :: MakeEffectConf -> MakeEffectConf
noGenerateNormalSenderFunction = (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf ((EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf)
-> (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Maybe SenderFunctionConf -> Identity (Maybe SenderFunctionConf))
-> EffectConf -> Identity EffectConf
Lens' EffectConf (Maybe SenderFunctionConf)
normalSenderGenConf ((Maybe SenderFunctionConf -> Identity (Maybe SenderFunctionConf))
 -> EffectConf -> Identity EffectConf)
-> Maybe SenderFunctionConf -> EffectConf -> EffectConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe SenderFunctionConf
forall a. Maybe a
Nothing
{-# INLINE noGenerateNormalSenderFunction #-}

noGenerateTaggedSenderFunction :: MakeEffectConf -> MakeEffectConf
noGenerateTaggedSenderFunction :: MakeEffectConf -> MakeEffectConf
noGenerateTaggedSenderFunction = (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf ((EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf)
-> (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Maybe SenderFunctionConf -> Identity (Maybe SenderFunctionConf))
-> EffectConf -> Identity EffectConf
Lens' EffectConf (Maybe SenderFunctionConf)
taggedSenderGenConf ((Maybe SenderFunctionConf -> Identity (Maybe SenderFunctionConf))
 -> EffectConf -> Identity EffectConf)
-> Maybe SenderFunctionConf -> EffectConf -> EffectConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe SenderFunctionConf
forall a. Maybe a
Nothing
{-# INLINE noGenerateTaggedSenderFunction #-}

noGenerateKeyedSenderFunction :: MakeEffectConf -> MakeEffectConf
noGenerateKeyedSenderFunction :: MakeEffectConf -> MakeEffectConf
noGenerateKeyedSenderFunction = (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf ((EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf)
-> (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Maybe SenderFunctionConf -> Identity (Maybe SenderFunctionConf))
-> EffectConf -> Identity EffectConf
Lens' EffectConf (Maybe SenderFunctionConf)
keyedSenderGenConf ((Maybe SenderFunctionConf -> Identity (Maybe SenderFunctionConf))
 -> EffectConf -> Identity EffectConf)
-> Maybe SenderFunctionConf -> EffectConf -> EffectConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe SenderFunctionConf
forall a. Maybe a
Nothing
{-# INLINE noGenerateKeyedSenderFunction #-}

suppressFirstOrderInHigherOrderEffectWarning :: MakeEffectConf -> MakeEffectConf
suppressFirstOrderInHigherOrderEffectWarning :: MakeEffectConf -> MakeEffectConf
suppressFirstOrderInHigherOrderEffectWarning = (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf ((EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf)
-> (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (Bool -> Identity Bool) -> EffectConf -> Identity EffectConf
Lens' EffectConf Bool
warnFirstOrderInHOE ((Bool -> Identity Bool) -> EffectConf -> Identity EffectConf)
-> Bool -> EffectConf -> EffectConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE suppressFirstOrderInHigherOrderEffectWarning #-}

noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf
noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf
noGenerateSenderFunctionSignature =
    (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf ((EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf)
-> (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ (SenderFunctionConf -> Identity SenderFunctionConf)
-> EffectConf -> Identity EffectConf
Traversal' EffectConf SenderFunctionConf
senderFnConfs ((SenderFunctionConf -> Identity SenderFunctionConf)
 -> EffectConf -> Identity EffectConf)
-> (SenderFunctionConf -> SenderFunctionConf)
-> EffectConf
-> EffectConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Bool -> Identity Bool)
-> SenderFunctionConf -> Identity SenderFunctionConf
Lens' SenderFunctionConf Bool
doesGenerateSenderFnSignature ((Bool -> Identity Bool)
 -> SenderFunctionConf -> Identity SenderFunctionConf)
-> Bool -> SenderFunctionConf -> SenderFunctionConf
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE noGenerateSenderFunctionSignature #-}

instance Default MakeEffectConf where
    def :: MakeEffectConf
def = (EffClsInfo -> Q EffectClassConf) -> MakeEffectConf
MakeEffectConf ((EffClsInfo -> Q EffectClassConf) -> MakeEffectConf)
-> (EffClsInfo -> Q EffectClassConf) -> MakeEffectConf
forall a b. (a -> b) -> a -> b
$ Q EffectClassConf -> EffClsInfo -> Q EffectClassConf
forall a b. a -> b -> a
const (Q EffectClassConf -> EffClsInfo -> Q EffectClassConf)
-> Q EffectClassConf -> EffClsInfo -> Q EffectClassConf
forall a b. (a -> b) -> a -> b
$ EffectClassConf -> Q EffectClassConf
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EffectClassConf
forall a. Default a => a
def
    {-# INLINE def #-}

instance Default EffectClassConf where
    def :: EffectClassConf
def =
        EffectClassConf
            { _confByEffect :: Name -> EffectConf
_confByEffect = \Name
effConName ->
                let normalSenderFnConf :: SenderFunctionConf
normalSenderFnConf =
                        SenderFunctionConf
                            { _senderFnName :: String
_senderFnName =
                                let effConName' :: String
effConName' = Name -> String
nameBase Name
effConName
                                 in if String -> Char
forall a. HasCallStack => [a] -> a
head String
effConName' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
                                        then ShowS
forall a. HasCallStack => [a] -> [a]
tail String
effConName'
                                        else String
effConName' String -> ShowS -> 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) -> ShowS
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Char -> Char
toLower
                            , _doesGenerateSenderFnSignature :: Bool
_doesGenerateSenderFnSignature = Bool
True
                            , _senderFnDoc :: Maybe String -> Q (Maybe String)
_senderFnDoc = Maybe String -> Q (Maybe String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            , _senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)
_senderFnArgDoc = (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 EffectConf
                        { _normalSenderGenConf :: Maybe SenderFunctionConf
_normalSenderGenConf = SenderFunctionConf -> Maybe SenderFunctionConf
forall a. a -> Maybe a
Just SenderFunctionConf
normalSenderFnConf
                        , _taggedSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf =
                            SenderFunctionConf -> Maybe SenderFunctionConf
forall a. a -> Maybe a
Just (SenderFunctionConf -> Maybe SenderFunctionConf)
-> SenderFunctionConf -> Maybe SenderFunctionConf
forall a b. (a -> b) -> a -> b
$ SenderFunctionConf
normalSenderFnConf SenderFunctionConf
-> (SenderFunctionConf -> SenderFunctionConf) -> SenderFunctionConf
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> SenderFunctionConf -> Identity SenderFunctionConf
Lens' SenderFunctionConf String
senderFnName ((String -> Identity String)
 -> SenderFunctionConf -> Identity SenderFunctionConf)
-> ShowS -> SenderFunctionConf -> SenderFunctionConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'")
                        , _keyedSenderGenConf :: Maybe SenderFunctionConf
_keyedSenderGenConf =
                            SenderFunctionConf -> Maybe SenderFunctionConf
forall a. a -> Maybe a
Just (SenderFunctionConf -> Maybe SenderFunctionConf)
-> SenderFunctionConf -> Maybe SenderFunctionConf
forall a b. (a -> b) -> a -> b
$ SenderFunctionConf
normalSenderFnConf SenderFunctionConf
-> (SenderFunctionConf -> SenderFunctionConf) -> SenderFunctionConf
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> SenderFunctionConf -> Identity SenderFunctionConf
Lens' SenderFunctionConf String
senderFnName ((String -> Identity String)
 -> SenderFunctionConf -> Identity SenderFunctionConf)
-> ShowS -> SenderFunctionConf -> SenderFunctionConf
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"''")
                        , _warnFirstOrderInHOE :: Bool
_warnFirstOrderInHOE = Bool
True
                        }
            , _doesDeriveHFunctor :: Bool
_doesDeriveHFunctor = Bool
True
            , _doesGenerateLiftFOETypeSynonym :: Bool
_doesGenerateLiftFOETypeSynonym = Bool
True
            , _doesGenerateLiftFOEPatternSynonyms :: Bool
_doesGenerateLiftFOEPatternSynonyms = Bool
True
            }

genSenders :: EffectClassConf -> EffClsInfo -> Q [Dec]
genSenders :: EffectClassConf -> EffClsInfo -> Q [Dec]
genSenders EffectClassConf{Bool
Name -> EffectConf
_confByEffect :: EffectClassConf -> Name -> EffectConf
_doesDeriveHFunctor :: EffectClassConf -> Bool
_doesGenerateLiftFOETypeSynonym :: EffectClassConf -> Bool
_doesGenerateLiftFOEPatternSynonyms :: EffectClassConf -> Bool
_confByEffect :: Name -> EffectConf
_doesDeriveHFunctor :: Bool
_doesGenerateLiftFOETypeSynonym :: Bool
_doesGenerateLiftFOEPatternSynonyms :: Bool
..} ec :: EffClsInfo
ec@EffClsInfo{[TyVarBndr ()]
[EffConInfo]
Maybe (TyVarBndr ())
Name
ecName :: EffClsInfo -> Name
ecParamVars :: EffClsInfo -> [TyVarBndr ()]
ecCarrier :: EffClsInfo -> Maybe (TyVarBndr ())
ecEffs :: EffClsInfo -> [EffConInfo]
ecName :: Name
ecParamVars :: [TyVarBndr ()]
ecCarrier :: Maybe (TyVarBndr ())
ecEffs :: [EffConInfo]
..} = do
    let order :: EffectOrder
order = EffClsInfo -> EffectOrder
orderOf EffClsInfo
ec

    WriterT [Dec] Q [()] -> Q [Dec]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [Dec] Q [()] -> Q [Dec])
-> WriterT [Dec] Q [()] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [EffConInfo]
-> (EffConInfo -> WriterT [Dec] Q ()) -> WriterT [Dec] Q [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [EffConInfo]
ecEffs \con :: EffConInfo
con@EffConInfo{[Type]
[TyVarBndrSpec]
Maybe (TyVarBndr ())
Type
Name
effName :: EffConInfo -> Name
effParamTypes :: EffConInfo -> [Type]
effDataType :: EffConInfo -> Type
effResultType :: EffConInfo -> Type
effTyVars :: EffConInfo -> [TyVarBndrSpec]
effCarrier :: EffConInfo -> Maybe (TyVarBndr ())
effCxt :: EffConInfo -> [Type]
effName :: Name
effParamTypes :: [Type]
effDataType :: Type
effResultType :: Type
effTyVars :: [TyVarBndrSpec]
effCarrier :: Maybe (TyVarBndr ())
effCxt :: [Type]
..} -> do
        let EffectConf{Bool
Maybe SenderFunctionConf
_normalSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_taggedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_keyedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_warnFirstOrderInHOE :: EffectConf -> Bool
_normalSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf :: Maybe SenderFunctionConf
_keyedSenderGenConf :: Maybe SenderFunctionConf
_warnFirstOrderInHOE :: Bool
..} = Name -> EffectConf
_confByEffect Name
effName

        Maybe SenderFunctionConf
-> (SenderFunctionConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SenderFunctionConf
_normalSenderGenConf \SenderFunctionConf
conf -> EffectOrder
-> SenderFunctionConf -> EffConInfo -> WriterT [Dec] Q ()
genNormalSender EffectOrder
order SenderFunctionConf
conf EffConInfo
con
        Maybe SenderFunctionConf
-> (SenderFunctionConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SenderFunctionConf
_taggedSenderGenConf \SenderFunctionConf
conf -> EffectOrder
-> SenderFunctionConf -> EffConInfo -> WriterT [Dec] Q ()
genTaggedSender EffectOrder
order SenderFunctionConf
conf EffConInfo
con
        Maybe SenderFunctionConf
-> (SenderFunctionConf -> WriterT [Dec] Q ()) -> WriterT [Dec] Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SenderFunctionConf
_keyedSenderGenConf \SenderFunctionConf
conf -> EffectOrder
-> SenderFunctionConf -> EffConInfo -> WriterT [Dec] Q ()
genKeyedSender EffectOrder
order SenderFunctionConf
conf EffConInfo
con

        -- Check for First Order in Higher Order effect warning
        Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
_warnFirstOrderInHOE Bool -> Bool -> Bool
&& EffectOrder
order EffectOrder -> EffectOrder -> Bool
forall a. Eq a => a -> a -> Bool
== EffectOrder
HigherOrder) do
            let isHigherOrderEffect :: Bool
isHigherOrderEffect = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName (Maybe (TyVarBndr ()) -> TyVarBndr ()
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TyVarBndr ())
effCarrier) `occurs`) [Type]
effParamTypes

            Bool -> WriterT [Dec] Q () -> WriterT [Dec] Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isHigherOrderEffect do
                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
$
                    String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
                        String
"The first-order operation ‘"
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
effName
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"’ has been found within the higher-order effect data type ‘"
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
ecName
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"’.\nConsider separating the first-order operation into an first-order effect data type."

genNormalSender
    :: EffectOrder
    -> SenderFunctionConf
    -> EffConInfo
    -> WriterT [Dec] Q ()
genNormalSender :: EffectOrder
-> SenderFunctionConf -> EffConInfo -> WriterT [Dec] Q ()
genNormalSender EffectOrder
order = EffectOrder
-> (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> SenderFunctionConf
-> EffConInfo
-> WriterT [Dec] Q ()
genSender EffectOrder
order Exp -> Exp
send Type -> Type -> Type
sendCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. a -> a
id
  where
    (Exp -> Exp
send, Type -> Type -> Type
sendCxt) = case EffectOrder
order of
        EffectOrder
FirstOrder ->
            ( (Name -> Exp
VarE 'sendFOE `AppE`)
            , \Type
effDataType Type
carrier -> Name -> Type
ConT ''SendFOE Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
carrier
            )
        EffectOrder
HigherOrder ->
            ( (Name -> Exp
VarE 'sendHOE `AppE`)
            , \Type
effDataType Type
carrier -> Name -> Type
ConT ''SendHOE Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
carrier
            )

genTaggedSender
    :: EffectOrder
    -> SenderFunctionConf
    -> EffConInfo
    -> WriterT [Dec] Q ()
genTaggedSender :: EffectOrder
-> SenderFunctionConf -> EffConInfo -> WriterT [Dec] Q ()
genTaggedSender EffectOrder
order SenderFunctionConf
conf EffConInfo
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
send, Type -> Type -> Type
sendCxt) = case EffectOrder
order of
            EffectOrder
FirstOrder ->
                ( (Name -> Exp
VarE 'sendFOE `AppE`) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp
ConE 'Tag Exp -> Type -> Exp
`AppTypeE` Type
WildCardT Exp -> Type -> Exp
`AppTypeE` Type
tag `AppE`)
                , \Type
effDataType Type
carrier ->
                    Name -> Type
ConT ''SendFOE Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Tag Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
tag) Type -> Type -> Type
`AppT` Type
carrier
                )
            EffectOrder
HigherOrder ->
                ( (Name -> Exp
VarE 'sendHOE `AppE`) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp
ConE 'TagH Exp -> Type -> Exp
`AppTypeE` Type
WildCardT Exp -> Type -> Exp
`AppTypeE` Type
tag `AppE`)
                , \Type
effDataType Type
carrier ->
                    Name -> Type
ConT ''SendHOE Type -> Type -> Type
`AppT` (Name -> Type
ConT ''TagH Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
tag) Type -> Type -> Type
`AppT` Type
carrier
                )

    EffectOrder
-> (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> SenderFunctionConf
-> EffConInfo
-> WriterT [Dec] Q ()
genSender EffectOrder
order Exp -> Exp
send Type -> Type -> Type
sendCxt (Name -> Specificity -> TyVarBndrSpec
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
nTag Specificity
SpecifiedSpec :) SenderFunctionConf
conf EffConInfo
eff

genKeyedSender
    :: EffectOrder
    -> SenderFunctionConf
    -> EffConInfo
    -> WriterT [Dec] Q ()
genKeyedSender :: EffectOrder
-> SenderFunctionConf -> EffConInfo -> WriterT [Dec] Q ()
genKeyedSender EffectOrder
order SenderFunctionConf
conf EffConInfo
eff = 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
send, Type -> Type -> Type
sendCxt) = case EffectOrder
order of
            EffectOrder
FirstOrder ->
                ( (Name -> Exp
VarE 'sendFOEBy Exp -> Type -> Exp
`AppTypeE` Type
key `AppE`)
                , \Type
effDataType Type
carrier ->
                    Name -> Type
ConT ''SendFOEBy Type -> Type -> Type
`AppT` Type
key Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
carrier
                )
            EffectOrder
HigherOrder ->
                ( (Name -> Exp
VarE 'sendHOEBy Exp -> Type -> Exp
`AppTypeE` Type
key `AppE`)
                , \Type
effDataType Type
carrier ->
                    Name -> Type
ConT ''SendHOEBy Type -> Type -> Type
`AppT` Type
key Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
carrier
                )

    EffectOrder
-> (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> SenderFunctionConf
-> EffConInfo
-> WriterT [Dec] Q ()
genSender EffectOrder
order Exp -> Exp
send Type -> Type -> Type
sendCxt (Name -> Specificity -> TyVarBndrSpec
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
nKey Specificity
SpecifiedSpec :) SenderFunctionConf
conf EffConInfo
eff

genSender
    :: EffectOrder
    -> (Exp -> Exp)
    -> (TH.Type -> TH.Type -> TH.Type)
    -> ([TyVarBndrSpec] -> [TyVarBndrSpec])
    -> SenderFunctionConf
    -> EffConInfo
    -> WriterT [Dec] Q ()
genSender :: EffectOrder
-> (Exp -> Exp)
-> (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> SenderFunctionConf
-> EffConInfo
-> WriterT [Dec] Q ()
genSender EffectOrder
order Exp -> Exp
send Type -> Type -> Type
sendCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs conf :: SenderFunctionConf
conf@SenderFunctionConf{Bool
String
Int -> Maybe String -> Q (Maybe String)
Maybe String -> Q (Maybe String)
_senderFnName :: SenderFunctionConf -> String
_doesGenerateSenderFnSignature :: SenderFunctionConf -> Bool
_senderFnDoc :: SenderFunctionConf -> Maybe String -> Q (Maybe String)
_senderFnArgDoc :: SenderFunctionConf -> Int -> Maybe String -> Q (Maybe String)
_senderFnName :: String
_doesGenerateSenderFnSignature :: Bool
_senderFnDoc :: Maybe String -> Q (Maybe String)
_senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)
..} con :: EffConInfo
con@EffConInfo{[Type]
[TyVarBndrSpec]
Maybe (TyVarBndr ())
Type
Name
effName :: EffConInfo -> Name
effParamTypes :: EffConInfo -> [Type]
effDataType :: EffConInfo -> Type
effResultType :: EffConInfo -> Type
effTyVars :: EffConInfo -> [TyVarBndrSpec]
effCarrier :: EffConInfo -> Maybe (TyVarBndr ())
effCxt :: EffConInfo -> [Type]
effName :: Name
effParamTypes :: [Type]
effDataType :: Type
effResultType :: Type
effTyVars :: [TyVarBndrSpec]
effCarrier :: Maybe (TyVarBndr ())
effCxt :: [Type]
..} = do
    (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> SenderFunctionConf
-> EffConInfo
-> (Type -> Q Clause)
-> WriterT [Dec] Q ()
genSenderArmor Type -> Type -> Type
sendCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs SenderFunctionConf
conf EffConInfo
con \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]
effParamTypes) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")

        let body :: Exp
body =
                Exp -> Exp
send
                    ( (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
effName) ((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
_doesGenerateSenderFnSignature
                            then (Exp -> Type -> Exp
`SigE` ((Type
effDataType Type -> (Type -> Type) -> Type
forall a b. a -> (a -> b) -> b
& Type -> Type
appCarrier) Type -> Type -> Type
`AppT` Type
effResultType))
                            else Exp -> Exp
forall a. a -> a
id
                    )

            appCarrier :: Type -> Type
appCarrier = case EffectOrder
order of
                EffectOrder
FirstOrder -> Type -> Type
forall a. a -> a
id
                EffectOrder
HigherOrder -> (Type -> Type -> Type
`AppT` Type
f)

        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) []

genSenderArmor
    :: (TH.Type -> TH.Type -> TH.Type)
    -> ([TyVarBndrSpec] -> [TyVarBndrSpec])
    -> SenderFunctionConf
    -> EffConInfo
    -> (Type -> Q Clause)
    -> WriterT [Dec] Q ()
genSenderArmor :: (Type -> Type -> Type)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> SenderFunctionConf
-> EffConInfo
-> (Type -> Q Clause)
-> WriterT [Dec] Q ()
genSenderArmor Type -> Type -> Type
sendCxt [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs SenderFunctionConf{Bool
String
Int -> Maybe String -> Q (Maybe String)
Maybe String -> Q (Maybe String)
_senderFnName :: SenderFunctionConf -> String
_doesGenerateSenderFnSignature :: SenderFunctionConf -> Bool
_senderFnDoc :: SenderFunctionConf -> Maybe String -> Q (Maybe String)
_senderFnArgDoc :: SenderFunctionConf -> Int -> Maybe String -> Q (Maybe String)
_senderFnName :: String
_doesGenerateSenderFnSignature :: Bool
_senderFnDoc :: Maybe String -> Q (Maybe String)
_senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)
..} EffConInfo{[Type]
[TyVarBndrSpec]
Maybe (TyVarBndr ())
Type
Name
effName :: EffConInfo -> Name
effParamTypes :: EffConInfo -> [Type]
effDataType :: EffConInfo -> Type
effResultType :: EffConInfo -> Type
effTyVars :: EffConInfo -> [TyVarBndrSpec]
effCarrier :: EffConInfo -> Maybe (TyVarBndr ())
effCxt :: EffConInfo -> [Type]
effName :: Name
effParamTypes :: [Type]
effDataType :: Type
effResultType :: Type
effTyVars :: [TyVarBndrSpec]
effCarrier :: Maybe (TyVarBndr ())
effCxt :: [Type]
..} Type -> Q Clause
clause = do
    TyVarBndr ()
carrier <- Q (TyVarBndr ())
-> (TyVarBndr () -> Q (TyVarBndr ()))
-> Maybe (TyVarBndr ())
-> Q (TyVarBndr ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ()) (Name -> TyVarBndr ()) -> Q Name -> Q (TyVarBndr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f") TyVarBndr () -> Q (TyVarBndr ())
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TyVarBndr ())
effCarrier Q (TyVarBndr ())
-> (Q (TyVarBndr ()) -> WriterT [Dec] Q (TyVarBndr ()))
-> WriterT [Dec] Q (TyVarBndr ())
forall a b. a -> (a -> b) -> b
& Q (TyVarBndr ()) -> WriterT [Dec] Q (TyVarBndr ())
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 f :: Type
f = TyVarBndr () -> Type
forall a. TyVarBndr a -> Type
tyVarType TyVarBndr ()
carrier

        fnName :: Name
fnName = String -> Name
mkName String
_senderFnName

        funSig :: Dec
funSig =
            Name -> Type -> Dec
SigD
                Name
fnName
                ( [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT
                    ([TyVarBndrSpec]
effTyVars [TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr ()
carrier TyVarBndr () -> Specificity -> TyVarBndrSpec
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Specificity
SpecifiedSpec] [TyVarBndrSpec]
-> ([TyVarBndrSpec] -> [TyVarBndrSpec]) -> [TyVarBndrSpec]
forall a b. a -> (a -> b) -> b
& [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs)
                    (Type -> Type -> Type
sendCxt Type
effDataType Type
f Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
effCxt)
                    ([Type] -> Type -> Type
forall (t :: * -> *). Foldable t => t Type -> Type -> Type
arrowChain [Type]
effParamTypes (Type
f Type -> Type -> Type
`AppT` Type
effResultType))
                )

        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
f 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 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
effName
        Maybe String -> Q (Maybe String)
_senderFnDoc 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
            Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
fnName) String
doc

        [Int] -> (Int -> Q ()) -> Q [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
effParamTypes 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
effName Int
i
            Int -> Maybe String -> Q (Maybe String)
_senderFnArgDoc 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
                Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ 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
_doesGenerateSenderFnSignature (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
    }

reifyEffCls :: EffectOrder -> Name -> Q (Info, DataInfo, EffClsInfo)
reifyEffCls :: EffectOrder -> Name -> Q (Info, DataInfo, EffClsInfo)
reifyEffCls EffectOrder
order 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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
pprint Name
name String -> ShowS
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

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

    pure (Info
info, DataInfo
dataInfo, EffClsInfo
effClsInfo)

analyzeEffCls :: EffectOrder -> DataInfo -> Either T.Text EffClsInfo
analyzeEffCls :: EffectOrder -> DataInfo -> Either Text EffClsInfo
analyzeEffCls EffectOrder
order 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, Maybe (TyVarBndr ())
mCarrier) <-
        case EffectOrder
order of
            EffectOrder
FirstOrder -> ([TyVarBndr ()], Maybe (TyVarBndr ()))
-> Either Text ([TyVarBndr ()], Maybe (TyVarBndr ()))
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr ()]
initTyVars, Maybe (TyVarBndr ())
forall a. Maybe a
Nothing)
            EffectOrder
HigherOrder -> do
                ([TyVarBndr ()]
pvs, 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."
                ([TyVarBndr ()], Maybe (TyVarBndr ()))
-> Either Text ([TyVarBndr ()], Maybe (TyVarBndr ()))
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr ()]
pvs, TyVarBndr () -> Maybe (TyVarBndr ())
forall a. a -> Maybe a
Just TyVarBndr ()
carrier)

    let analyzeEffCon :: ConInfo -> Validation [T.Text] EffConInfo
        analyzeEffCon :: ConInfo -> Validation [Text] EffConInfo
analyzeEffCon 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] EffConInfo -> Validation [Text] EffConInfo
forall e a. Either e a -> Validation e a
eitherToValidation do
            (Type
effDataType, Maybe (TyVarBndr ())
effCarrier, Type
effResultType) <-
                Either [Text] (Type, Maybe (TyVarBndr ()), Type)
-> (Type -> Either [Text] (Type, Maybe (TyVarBndr ()), Type))
-> Maybe Type
-> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    ( (Type, Maybe (TyVarBndr ()), Type)
-> Either [Text] (Type, Maybe (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)
                        , Maybe (TyVarBndr ())
mCarrier
                        , TyVarBndr () -> Type
forall a. TyVarBndr a -> Type
tyVarType TyVarBndr ()
resultType
                        )
                    )
                    Type -> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
decomposeGadtReturnType
                    Maybe Type
conGadtReturnType

            let removeCarrierTV :: [TyVarBndr a] -> [TyVarBndr a]
                removeCarrierTV :: forall a. [TyVarBndr a] -> [TyVarBndr a]
removeCarrierTV = case EffectOrder
order of
                    EffectOrder
FirstOrder -> [TyVarBndr a] -> [TyVarBndr a]
forall a. a -> a
id
                    EffectOrder
HigherOrder -> (TyVarBndr a -> Bool) -> [TyVarBndr a] -> [TyVarBndr a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName (TyVarBndr () -> Name) -> Maybe (TyVarBndr ()) -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TyVarBndr ())
effCarrier /=) (Maybe Name -> Bool)
-> (TyVarBndr a -> Maybe Name) -> TyVarBndr a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name)
-> (TyVarBndr a -> Name) -> TyVarBndr a -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr a -> Name
forall a. TyVarBndr a -> Name
tyVarName)

                effTyVars :: [TyVarBndrSpec]
effTyVars =
                    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

            EffConInfo -> Either [Text] EffConInfo
forall a b. b -> Either a b
Right
                EffConInfo
                    { effName :: Name
effName = Name
conName
                    , effParamTypes :: [Type]
effParamTypes = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
conArgs
                    , effDataType :: Type
effDataType = Type
effDataType
                    , effResultType :: Type
effResultType = Type
effResultType
                    , effTyVars :: [TyVarBndrSpec]
effTyVars = [TyVarBndrSpec]
effTyVars
                    , effCarrier :: Maybe (TyVarBndr ())
effCarrier = Maybe (TyVarBndr ())
effCarrier
                    , effCxt :: [Type]
effCxt = [Type]
conCxt
                    }
          where
            decomposeGadtReturnType
                :: TH.Type -> Either [T.Text] (TH.Type, Maybe (TyVarBndr ()), TH.Type)
            decomposeGadtReturnType :: Type -> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
decomposeGadtReturnType =
                Type -> Type
unkindType (Type -> Type)
-> (Type -> Either [Text] (Type, Maybe (TyVarBndr ()), Type))
-> Type
-> Either [Text] (Type, Maybe (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 EffectOrder
order of
                    EffectOrder
FirstOrder ->
                        \case
                            Type
ins `AppT` Type
x -> (Type, Maybe (TyVarBndr ()), Type)
-> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
forall a b. b -> Either a b
Right (Type
ins, Maybe (TyVarBndr ())
forall a. Maybe a
Nothing, Type
x)
                            Type
t ->
                                [Text] -> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
forall a b. a -> Either a b
Left
                                    [ Text
"Unexpected form of GADT return type for the first-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)
                                    ]
                    EffectOrder
HigherOrder -> \case
                        Type
sig `AppT` SigT (VarT Name
f) Type
kf `AppT` Type
x ->
                            (Type, Maybe (TyVarBndr ()), Type)
-> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
forall a b. b -> Either a b
Right (Type
sig, TyVarBndr () -> Maybe (TyVarBndr ())
forall a. a -> Maybe a
Just (Name -> () -> Type -> TyVarBndr ()
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
f () Type
kf), Type
x)
                        Type
sig `AppT` VarT Name
f `AppT` Type
x ->
                            (Type, Maybe (TyVarBndr ()), Type)
-> Either [Text] (Type, Maybe (TyVarBndr ()), Type)
forall a b. b -> Either a b
Right (Type
sig, TyVarBndr () -> Maybe (TyVarBndr ())
forall a. a -> Maybe a
Just (Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
f ()), Type
x)
                        Type
t ->
                            [Text] -> Either [Text] (Type, Maybe (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)
                                ]

    [EffConInfo]
effCons <-
        (ConInfo -> Validation [Text] EffConInfo)
-> [ConInfo] -> Validation [Text] [EffConInfo]
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] EffConInfo
analyzeEffCon [ConInfo]
dataCons
            Validation [Text] [EffConInfo]
-> (Validation [Text] [EffConInfo] -> Either [Text] [EffConInfo])
-> Either [Text] [EffConInfo]
forall a b. a -> (a -> b) -> b
& Validation [Text] [EffConInfo] -> Either [Text] [EffConInfo]
forall e a. Validation e a -> Either e a
validationToEither
            Either [Text] [EffConInfo]
-> (Either [Text] [EffConInfo] -> Either Text [EffConInfo])
-> Either Text [EffConInfo]
forall a b. a -> (a -> b) -> b
& ([Text] -> Text)
-> Either [Text] [EffConInfo] -> Either Text [EffConInfo]
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft [Text] -> Text
T.unlines

    pure
        EffClsInfo
            { ecName :: Name
ecName = Name
dataName
            , ecParamVars :: [TyVarBndr ()]
ecParamVars = [TyVarBndr ()]
paramVars
            , ecCarrier :: Maybe (TyVarBndr ())
ecCarrier = Maybe (TyVarBndr ())
mCarrier
            , ecEffs :: [EffConInfo]
ecEffs = [EffConInfo]
effCons
            }

-- ** Generating Synonyms about LiftFOE

{- |
Generate the pattern synonyms for operation constructors:

    @pattern LBaz ... = LiftFOE (Baz ...)@
-}
genLiftFOEPatternSynonyms :: EffClsInfo -> Q [Dec]
genLiftFOEPatternSynonyms :: EffClsInfo -> Q [Dec]
genLiftFOEPatternSynonyms EffClsInfo{[TyVarBndr ()]
[EffConInfo]
Maybe (TyVarBndr ())
Name
ecName :: EffClsInfo -> Name
ecParamVars :: EffClsInfo -> [TyVarBndr ()]
ecCarrier :: EffClsInfo -> Maybe (TyVarBndr ())
ecEffs :: EffClsInfo -> [EffConInfo]
ecName :: Name
ecParamVars :: [TyVarBndr ()]
ecCarrier :: Maybe (TyVarBndr ())
ecEffs :: [EffConInfo]
..} = do
    [(Name, [Dec])]
patSyns <-
        [EffConInfo]
-> (EffConInfo -> Q (Name, [Dec])) -> Q [(Name, [Dec])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [EffConInfo]
ecEffs \EffConInfo{[Type]
[TyVarBndrSpec]
Maybe (TyVarBndr ())
Type
Name
effName :: EffConInfo -> Name
effParamTypes :: EffConInfo -> [Type]
effDataType :: EffConInfo -> Type
effResultType :: EffConInfo -> Type
effTyVars :: EffConInfo -> [TyVarBndrSpec]
effCarrier :: EffConInfo -> Maybe (TyVarBndr ())
effCxt :: EffConInfo -> [Type]
effName :: Name
effParamTypes :: [Type]
effDataType :: Type
effResultType :: Type
effTyVars :: [TyVarBndrSpec]
effCarrier :: Maybe (TyVarBndr ())
effCxt :: [Type]
..} -> do
            let newConName :: Name
newConName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'L' Char -> ShowS
forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
effName
            [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]
effParamTypes) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")

            Type
f <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
            Type
a <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"

            (Name
newConName,)
                ([Dec] -> (Name, [Dec])) -> Q [Dec] -> Q (Name, [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
                    [ Name -> Q Type -> Q Dec
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|
                            ()
                            => ( $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a) ~ $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
effResultType)
                               , $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (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 (Int -> Type
TupleT ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
effCxt)) [Type]
effCxt)
                               )
                            => $( Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$
                                    [Type] -> Type -> Type
forall (t :: * -> *). Foldable t => t Type -> Type -> Type
arrowChain
                                        [Type]
effParamTypes
                                        ((Name -> Type
ConT ''LiftFOE Type -> Type -> Type
`AppT` Type
effDataType) Type -> Type -> Type
`AppT` Type
f Type -> Type -> Type
`AppT` Type
a)
                                )
                            |]
                    , Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
                        Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD
                            Name
newConName
                            ([Name] -> PatSynArgs
PrefixPatSyn [Name]
args)
                            PatSynDir
ImplBidir
                            (Name -> [Type] -> [Pat] -> Pat
ConP 'LiftFOE [] [Name -> [Type] -> [Pat] -> Pat
ConP Name
effName [] (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)])
                    ]

    pure $ ((Name, [Dec]) -> [Dec]) -> [(Name, [Dec])] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd [(Name, [Dec])]
patSyns [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe Name -> Pragma
CompleteP ((Name, [Dec]) -> Name
forall a b. (a, b) -> a
fst ((Name, [Dec]) -> Name) -> [(Name, [Dec])] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, [Dec])]
patSyns) Maybe Name
forall a. Maybe a
Nothing]

{- |
Generate the type synonym for an first-order effect datatype:

    @type (LFoobar ...) = LiftFOE (Foobar ...)@
-}
genLiftFOETypeSynonym :: EffClsInfo -> Dec
genLiftFOETypeSynonym :: EffClsInfo -> Dec
genLiftFOETypeSynonym EffClsInfo{[TyVarBndr ()]
[EffConInfo]
Maybe (TyVarBndr ())
Name
ecName :: EffClsInfo -> Name
ecParamVars :: EffClsInfo -> [TyVarBndr ()]
ecCarrier :: EffClsInfo -> Maybe (TyVarBndr ())
ecEffs :: EffClsInfo -> [EffConInfo]
ecName :: Name
ecParamVars :: [TyVarBndr ()]
ecCarrier :: Maybe (TyVarBndr ())
ecEffs :: [EffConInfo]
..} = do
    Name -> [TyVarBndr BndrVis] -> Type -> Dec
TySynD
        (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'L' Char -> ShowS
forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
ecName)
        ([Name]
pvs [Name] -> (Name -> TyVarBndr BndrVis) -> [TyVarBndr BndrVis]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` BndrVis
BndrReq))
        (Name -> Type
ConT ''LiftFOE Type -> Type -> Type
`AppT` (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
ecName) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
pvs))
  where
    pvs :: [Name]
pvs = TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
ecParamVars

-- * 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."