{-# 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 Yamada Ryo
               (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 (SendIns, SendSig, sendIns, sendSig)
import Control.Effect.Key (SendInsBy, SendSigBy, sendInsBy, sendSigBy)
import Control.Monad.Writer (WriterT, execWriterT, lift, tell)
import Data.Char (toLower)
import Data.Default (Default, def)
import Data.Effect (LiftIns (LiftIns))
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

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

orderOf :: EffClsInfo -> EffectOrder
orderOf :: EffClsInfo -> EffectOrder
orderOf =
    EffClsInfo -> Maybe (TyVarBndr ())
ecCarrier 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EffectClassConf -> EffectClassConf
f 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 :: Name -> EffectConf
_confByEffect = EffectConf -> EffectConf
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectClassConf -> Name -> EffectConf
_confByEffect EffectClassConf
conf}

data EffectClassConf = EffectClassConf
    { EffectClassConf -> Name -> EffectConf
_confByEffect :: Name -> EffectConf
    , EffectClassConf -> Bool
_doesDeriveHFunctor :: Bool
    , EffectClassConf -> Bool
_doesGenerateLiftInsTypeSynonym :: Bool
    , EffectClassConf -> Bool
_doesGenerateLiftInsPatternSynonyms :: Bool
    }

data EffectConf = EffectConf
    { EffectConf -> Maybe SenderFunctionConf
_normalSenderGenConf :: Maybe SenderFunctionConf
    , EffectConf -> Maybe SenderFunctionConf
_taggedSenderGenConf :: Maybe SenderFunctionConf
    , EffectConf -> Maybe SenderFunctionConf
_keyedSenderGenConf :: Maybe SenderFunctionConf
    , EffectConf -> Bool
_warnFirstOrderInSigCls :: 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
_warnFirstOrderInSigCls :: Bool
_keyedSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf :: Maybe SenderFunctionConf
_normalSenderGenConf :: Maybe SenderFunctionConf
_warnFirstOrderInSigCls :: EffectConf -> Bool
_keyedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_taggedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_normalSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
..} = do
    Maybe SenderFunctionConf
normal <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SenderFunctionConf -> f SenderFunctionConf
f Maybe SenderFunctionConf
_normalSenderGenConf
    Maybe SenderFunctionConf
tagged <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SenderFunctionConf -> f SenderFunctionConf
f Maybe SenderFunctionConf
_taggedSenderGenConf
    Maybe SenderFunctionConf
keyed <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
_warnFirstOrderInSigCls :: Bool
_warnFirstOrderInSigCls :: Bool
_warnFirstOrderInSigCls
            }

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

deriveHFunctor :: MakeEffectConf -> MakeEffectConf
deriveHFunctor :: MakeEffectConf -> MakeEffectConf
deriveHFunctor = (EffectClassConf -> EffectClassConf)
-> MakeEffectConf -> MakeEffectConf
alterEffectClassConf forall a b. (a -> b) -> a -> b
$ Lens' EffectClassConf Bool
doesDeriveHFunctor 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 forall a b. (a -> b) -> a -> b
$ Lens' EffectClassConf Bool
doesDeriveHFunctor forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
{-# INLINE noDeriveHFunctor #-}

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

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

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

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

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

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

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

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

noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf
noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf
noGenerateSenderFunctionSignature =
    (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf
alterEffectConf forall a b. (a -> b) -> a -> b
$ Traversal' EffectConf SenderFunctionConf
senderFnConfs forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Lens' SenderFunctionConf Bool
doesGenerateSenderFnSignature 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 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a. [a] -> a
head String
effConName' forall a. Eq a => a -> a -> Bool
== Char
':'
                                        then forall a. [a] -> [a]
tail String
effConName'
                                        else String
effConName' forall a b. a -> (a -> b) -> b
& forall s a. Cons s s a a => Traversal' s a
_head forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Char -> Char
toLower
                            , _doesGenerateSenderFnSignature :: Bool
_doesGenerateSenderFnSignature = Bool
True
                            , _senderFnDoc :: Maybe String -> Q (Maybe String)
_senderFnDoc = forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            , _senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)
_senderFnArgDoc = forall a b. a -> b -> a
const forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            }
                 in EffectConf
                        { _normalSenderGenConf :: Maybe SenderFunctionConf
_normalSenderGenConf = forall a. a -> Maybe a
Just SenderFunctionConf
normalSenderFnConf
                        , _taggedSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf =
                            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SenderFunctionConf
normalSenderFnConf forall a b. a -> (a -> b) -> b
& Lens' SenderFunctionConf String
senderFnName forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ String
"'")
                        , _keyedSenderGenConf :: Maybe SenderFunctionConf
_keyedSenderGenConf =
                            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SenderFunctionConf
normalSenderFnConf forall a b. a -> (a -> b) -> b
& Lens' SenderFunctionConf String
senderFnName forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ String
"''")
                        , _warnFirstOrderInSigCls :: Bool
_warnFirstOrderInSigCls = Bool
True
                        }
            , _doesDeriveHFunctor :: Bool
_doesDeriveHFunctor = Bool
True
            , _doesGenerateLiftInsTypeSynonym :: Bool
_doesGenerateLiftInsTypeSynonym = Bool
True
            , _doesGenerateLiftInsPatternSynonyms :: Bool
_doesGenerateLiftInsPatternSynonyms = Bool
True
            }

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

    forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall a b. (a -> b) -> a -> b
$ 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
effCxt :: [Type]
effCarrier :: Maybe (TyVarBndr ())
effTyVars :: [TyVarBndrSpec]
effResultType :: Type
effDataType :: Type
effParamTypes :: [Type]
effName :: Name
effCxt :: EffConInfo -> [Type]
effCarrier :: EffConInfo -> Maybe (TyVarBndr ())
effTyVars :: EffConInfo -> [TyVarBndrSpec]
effResultType :: EffConInfo -> Type
effDataType :: EffConInfo -> Type
effParamTypes :: EffConInfo -> [Type]
effName :: EffConInfo -> Name
..} -> do
        let EffectConf{Bool
Maybe SenderFunctionConf
_warnFirstOrderInSigCls :: Bool
_keyedSenderGenConf :: Maybe SenderFunctionConf
_taggedSenderGenConf :: Maybe SenderFunctionConf
_normalSenderGenConf :: Maybe SenderFunctionConf
_warnFirstOrderInSigCls :: EffectConf -> Bool
_keyedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_taggedSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
_normalSenderGenConf :: EffectConf -> Maybe SenderFunctionConf
..} = Name -> EffectConf
_confByEffect Name
effName

        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
        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
        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 Signature Class warning
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
_warnFirstOrderInSigCls Bool -> Bool -> Bool
&& EffectOrder
order forall a. Eq a => a -> a -> Bool
== EffectOrder
HigherOrder) do
            let isHigherOrderEffect :: Bool
isHigherOrderEffect = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. TyVarBndr a -> Name
tyVarName (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TyVarBndr ())
effCarrier) `occurs`) [Type]
effParamTypes

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isHigherOrderEffect do
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
                    String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$
                        String
"The first-order effect ‘"
                            forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
effName
                            forall a. Semigroup a => a -> a -> a
<> String
"’ has been found within the signature class data type ‘"
                            forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
ecName
                            forall a. Semigroup a => a -> a -> a
<> String
"’.\nConsider separating the first-order effect into an instruction class 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 forall a. a -> a
id
  where
    (Exp -> Exp
send, Type -> Type -> Type
sendCxt) = case EffectOrder
order of
        EffectOrder
FirstOrder ->
            ( (Name -> Exp
VarE 'sendIns `AppE`)
            , \Type
effDataType Type
carrier -> Name -> Type
ConT ''SendIns Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
carrier
            )
        EffectOrder
HigherOrder ->
            ( (Name -> Exp
VarE 'sendSig `AppE`)
            , \Type
effDataType Type
carrier -> Name -> Type
ConT ''SendSig 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"tag" forall a b. a -> (a -> b) -> b
& 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 'sendIns `AppE`) 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 ''SendIns 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 'sendSig `AppE`) 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 ''SendSig 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 (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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"key" forall a b. a -> (a -> b) -> b
& 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 'sendInsBy Exp -> Type -> Exp
`AppTypeE` Type
key `AppE`)
                , \Type
effDataType Type
carrier ->
                    Name -> Type
ConT ''SendInsBy Type -> Type -> Type
`AppT` Type
key Type -> Type -> Type
`AppT` Type
effDataType Type -> Type -> Type
`AppT` Type
carrier
                )
            EffectOrder
HigherOrder ->
                ( (Name -> Exp
VarE 'sendSigBy Exp -> Type -> Exp
`AppTypeE` Type
key `AppE`)
                , \Type
effDataType Type
carrier ->
                    Name -> Type
ConT ''SendSigBy 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 (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)
_senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)
_senderFnDoc :: Maybe String -> Q (Maybe String)
_doesGenerateSenderFnSignature :: Bool
_senderFnName :: String
_senderFnArgDoc :: SenderFunctionConf -> Int -> Maybe String -> Q (Maybe String)
_senderFnDoc :: SenderFunctionConf -> Maybe String -> Q (Maybe String)
_doesGenerateSenderFnSignature :: SenderFunctionConf -> Bool
_senderFnName :: SenderFunctionConf -> String
..} con :: EffConInfo
con@EffConInfo{[Type]
[TyVarBndrSpec]
Maybe (TyVarBndr ())
Type
Name
effCxt :: [Type]
effCarrier :: Maybe (TyVarBndr ())
effTyVars :: [TyVarBndrSpec]
effResultType :: Type
effDataType :: Type
effParamTypes :: [Type]
effName :: Name
effCxt :: EffConInfo -> [Type]
effCarrier :: EffConInfo -> Maybe (TyVarBndr ())
effTyVars :: EffConInfo -> [TyVarBndrSpec]
effResultType :: EffConInfo -> Type
effDataType :: EffConInfo -> Type
effParamTypes :: EffConInfo -> [Type]
effName :: EffConInfo -> Name
..} = 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
effParamTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")

        let body :: Exp
body =
                Exp -> Exp
send
                    ( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
effName) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
args)
                        forall a b. a -> (a -> b) -> b
& if Bool
_doesGenerateSenderFnSignature
                            then (Exp -> Type -> Exp
`SigE` ((Type
effDataType forall a b. a -> (a -> b) -> b
& Type -> Type
appCarrier) Type -> Type -> Type
`AppT` Type
effResultType))
                            else forall a. a -> a
id
                    )

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

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

    let f :: Type
f = 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 forall a. [a] -> [a] -> [a]
++ [TyVarBndr ()
carrier forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Specificity
SpecifiedSpec] forall a b. a -> (a -> b) -> b
& [TyVarBndrSpec] -> [TyVarBndrSpec]
alterFnSigTVs)
                    (Type -> Type -> Type
sendCxt Type
effDataType Type
f forall a. a -> [a] -> [a]
: [Type]
effCxt)
                    (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type -> Q Clause
clause Type
f forall a b. a -> (a -> b) -> b
& forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift]

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

        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
effParamTypes forall a. Num a => a -> a -> a
- Int
1] \Int
i -> do
            Maybe String
argDoc <- DocLoc -> Q (Maybe String)
getDoc 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \String
doc -> do
                Q () -> Q ()
addModFinalizer forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
putDoc (Name -> Int -> DocLoc
ArgDoc Name
fnName Int
i) String
doc

    -- Append declerations
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_doesGenerateSenderFnSignature forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Dec
funSig]
    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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> 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
            forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not datatype: ‘" forall a. Semigroup a => a -> a -> a
<> forall a. Ppr a => a -> String
pprint Name
name forall a. Semigroup a => a -> a -> a
<> String
"’") forall (f :: * -> *) a. Applicative f => a -> f a
pure

    EffClsInfo
effClsInfo <-
        EffectOrder -> DataInfo -> Either Text EffClsInfo
analyzeEffCls EffectOrder
order DataInfo
dataInfo
            forall a b. a -> (a -> b) -> b
& forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) 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
dataCons :: [ConInfo]
dataTyVars :: [TyVarBndr ()]
dataName :: Name
dataCxt :: [Type]
dataCons :: DataInfo -> [ConInfo]
dataTyVars :: DataInfo -> [TyVarBndr ()]
dataName :: DataInfo -> Name
dataCxt :: DataInfo -> [Type]
..} = do
    ([TyVarBndr ()]
initTyVars, TyVarBndr ()
resultType) <- forall a. [a] -> Maybe ([a], a)
unsnoc [TyVarBndr ()]
dataTyVars forall a b. a -> (a -> b) -> b
& 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr ()]
initTyVars, forall a. Maybe a
Nothing)
            EffectOrder
HigherOrder -> do
                ([TyVarBndr ()]
pvs, TyVarBndr ()
carrier) <- forall a. [a] -> Maybe ([a], a)
unsnoc [TyVarBndr ()]
initTyVars forall a b. a -> (a -> b) -> b
& forall a b. a -> Maybe b -> Either a b
maybeToEither Text
"No carrier type variable."
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr ()]
pvs, 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
conCxt :: [Type]
conTyVars :: [TyVarBndrSpec]
conGadtReturnType :: Maybe Type
conArgs :: [BangType]
conName :: Name
conCxt :: ConInfo -> [Type]
conTyVars :: ConInfo -> [TyVarBndrSpec]
conGadtReturnType :: ConInfo -> Maybe Type
conArgs :: ConInfo -> [BangType]
conName :: ConInfo -> Name
..} = forall e a. Either e a -> Validation e a
eitherToValidation do
            (Type
effDataType, Maybe (TyVarBndr ())
effCarrier, Type
effResultType) <-
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    ( forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        ( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
VarT Name
dataName) (forall a b. (a -> b) -> [a] -> [b]
map forall a. TyVarBndr a -> Type
tyVarType [TyVarBndr ()]
paramVars)
                        , Maybe (TyVarBndr ())
mCarrier
                        , 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 -> forall a. a -> a
id
                    EffectOrder
HigherOrder -> forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TyVarBndr ())
effCarrier /=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> Name
tyVarName)

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

            forall a b. b -> Either a b
Right
                EffConInfo
                    { effName :: Name
effName = Name
conName
                    , effParamTypes :: [Type]
effParamTypes = forall a b. (a -> b) -> [a] -> [b]
map 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 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 -> forall a b. b -> Either a b
Right (Type
ins, forall a. Maybe a
Nothing, Type
x)
                            Type
t ->
                                forall a b. a -> Either a b
Left
                                    [ Text
"Unexpected form of GADT return type for the instruction ‘"
                                        forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Name -> String
nameBase Name
conName)
                                        forall a. Semigroup a => a -> a -> a
<> Text
"’: "
                                        forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Ppr a => a -> String
pprint Type
t)
                                    ]
                    EffectOrder
HigherOrder -> \case
                        Type
sig `AppT` SigT (VarT Name
f) Type
kf `AppT` Type
x ->
                            forall a b. b -> Either a b
Right (Type
sig, forall a. a -> Maybe a
Just (forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
f () Type
kf), Type
x)
                        Type
sig `AppT` VarT Name
f `AppT` Type
x ->
                            forall a b. b -> Either a b
Right (Type
sig, forall a. a -> Maybe a
Just (forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
f ()), Type
x)
                        Type
t ->
                            forall a b. a -> Either a b
Left
                                [ Text
"Unexpected form of GADT return type for the signature ‘"
                                    forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Name -> String
nameBase Name
conName)
                                    forall a. Semigroup a => a -> a -> a
<> Text
"’: "
                                    forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Ppr a => a -> String
pprint Type
t)
                                ]

    [EffConInfo]
effCons <-
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConInfo -> Validation [Text] EffConInfo
analyzeEffCon [ConInfo]
dataCons
            forall a b. a -> (a -> b) -> b
& forall e a. Validation e a -> Either e a
validationToEither
            forall a b. a -> (a -> b) -> b
& 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 LiftIns

{- |
Generate the pattern synonyms for instruction constructors:

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

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

            (Name
newConName,)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                    [ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
patSynSigD
                        Name
newConName
                        -- For some reason, if I don't write constraints in this form, the type is
                        -- not inferred properly (why?).
                        [t|
                            () =>
                            ( $(pure a) ~ $(pure effResultType)
                            , $(pure $ foldl AppT (TupleT (length effCxt)) effCxt)
                            ) =>
                            $( pure $
                                arrowChain
                                    effParamTypes
                                    ((ConT ''LiftIns `AppT` effDataType) `AppT` f `AppT` a)
                             )
                            |]
                    , forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 'LiftIns [] [Name -> [Type] -> [Pat] -> Pat
ConP Name
effName [] (Name -> Pat
VarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)])
                    ]

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

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

    @type (LFoobar ...) = LiftIns (Foobar ...)@
-}
genLiftInsTypeSynonym :: EffClsInfo -> Dec
genLiftInsTypeSynonym :: EffClsInfo -> Dec
genLiftInsTypeSynonym EffClsInfo{[TyVarBndr ()]
[EffConInfo]
Maybe (TyVarBndr ())
Name
ecEffs :: [EffConInfo]
ecCarrier :: Maybe (TyVarBndr ())
ecParamVars :: [TyVarBndr ()]
ecName :: Name
ecEffs :: EffClsInfo -> [EffConInfo]
ecCarrier :: EffClsInfo -> Maybe (TyVarBndr ())
ecParamVars :: EffClsInfo -> [TyVarBndr ()]
ecName :: EffClsInfo -> Name
..} = do
    Name -> [TyVarBndr ()] -> Type -> Dec
TySynD
        (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Char
'L' forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
ecName)
        ([Name]
pvs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ()))
        (Name -> Type
ConT ''LiftIns Type -> Type -> Type
`AppT` forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
ecName) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
pvs))
  where
    pvs :: [Name]
pvs = forall a. TyVarBndr a -> Name
tyVarName 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar [TyVarBndrSpec]
vs) (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
_) = 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
|| 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 forall a. Eq a => a -> a -> Bool
== Name
m
    ConT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
    PromotedT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
    InfixT Type
l Name
n Type
r -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
    UInfixT Type
l Name
n Type
r -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
    ParensT Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
    AppKindT Type
t Type
_ -> Name
m Name -> Type -> Bool
`occurs` Type
t
    ImplicitParamT String
_ Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
    Type
_ -> Bool
False

{-  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 ()]
args Maybe Type
_ Con
constr [DerivClause]
_) ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [TyVarBndr ()] -> [ConInfo] -> DataInfo
DataInfo [Type]
cxt Name
name [TyVarBndr ()]
args (Con -> [ConInfo]
normalizeCon Con
constr)
    TyConI (DataD [Type]
cxt Name
name [TyVarBndr ()]
args Maybe Type
_ [Con]
constrs [DerivClause]
_) ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Type] -> Name -> [TyVarBndr ()] -> [ConInfo] -> DataInfo
DataInfo [Type]
cxt Name
name [TyVarBndr ()]
args (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [ConInfo]
normalizeCon [Con]
constrs)
    Info
_ -> forall a. Maybe a
Nothing

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