{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
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
}
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
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]
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
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
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
}
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
[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]
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
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
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
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
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
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
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."