{-# 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 (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
}
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
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]
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
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
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
}
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
[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]
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
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 (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
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
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
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."