{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Machinery.TH
(
makeEffect
, makeHandler
, makeFinder
, makeLifter
, makeTaggedEffect
, makeTaggedEffectWith
, makeTagger
, makeTaggerWith
, makeUntagged
, makeUntaggedWith
, liftL
, runL
, removeApostrophe
) where
import Control.Monad (forM, replicateM)
import Control.Monad.IO.Class (MonadIO)
import Data.Coerce (coerce)
import Data.List (isSuffixOf)
import Data.Maybe (catMaybes, maybeToList)
import Control.Monad.Trans.Control (liftWith, restoreT)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax hiding (Lift, lift)
import Control.Monad.Trans.Class (lift)
import Control.Effect.Machinery.Tagger (Tagger(..), runTagger)
import Control.Effect.Machinery.Via (Control, EachVia(..), Find, G, Handle,
Lift, Via, runVia)
data EffectInfo = EffectInfo
{ EffectInfo -> [Type]
effCxts :: [Type]
, EffectInfo -> Name
effName :: Name
, EffectInfo -> [TyVarBndr]
effParams :: [TyVarBndr]
, EffectInfo -> TyVarBndr
effMonad :: TyVarBndr
, EffectInfo -> [Signature]
effMethods :: [Signature]
}
data Signature = Signature
{ Signature -> Name
sigName :: Name
, Signature -> Type
sigType :: Type
}
effectInfo :: Name -> Q EffectInfo
effectInfo :: Name -> Q EffectInfo
effectInfo Name
className = do
Info
info <- Name -> Q Info
reify Name
className
case Info
info of
ClassI (ClassD [Type]
cxts Name
name [TyVarBndr]
tyVars [FunDep]
_ [Dec]
decs) [Dec]
_ -> do
([TyVarBndr]
params, TyVarBndr
monad) <-
case [TyVarBndr]
tyVars of
[] -> String -> Q ([TyVarBndr], TyVarBndr)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q ([TyVarBndr], TyVarBndr))
-> String -> Q ([TyVarBndr], TyVarBndr)
forall a b. (a -> b) -> a -> b
$ String
"The specified effect type class `"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' has no monad type variable. "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"It is expected to be the last type variable."
[TyVarBndr]
vs -> ([TyVarBndr], TyVarBndr) -> Q ([TyVarBndr], TyVarBndr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
vs, [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
vs)
let sigs :: [Signature]
sigs = [Name -> Type -> Signature
Signature Name
n Type
t | SigD Name
n Type
t <- [Dec]
decs]
EffectInfo -> Q EffectInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EffectInfo -> Q EffectInfo) -> EffectInfo -> Q EffectInfo
forall a b. (a -> b) -> a -> b
$ [Type]
-> Name -> [TyVarBndr] -> TyVarBndr -> [Signature] -> EffectInfo
EffectInfo [Type]
cxts Name
name [TyVarBndr]
params TyVarBndr
monad [Signature]
sigs
Info
other ->
String -> Q EffectInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q EffectInfo) -> String -> Q EffectInfo
forall a b. (a -> b) -> a -> b
$ String
"The specified name `"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a type class, but the following instead: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
other
effectType :: EffectInfo -> Q Type
effectType :: EffectInfo -> Q Type
effectType EffectInfo
info =
(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
( Q Type -> Q Type -> Q Type
appT )
( Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info )
( (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
superEffects :: EffectInfo -> [Type]
superEffects :: EffectInfo -> [Type]
superEffects EffectInfo
info =
[Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> [Type]) -> [Maybe Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Maybe Type) -> [Type] -> [Maybe Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Maybe Type
extract (EffectInfo -> [Type]
effCxts EffectInfo
info)
where
m :: Name
m = TyVarBndr -> Name
tyVarName (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
extract :: Type -> Maybe Type
extract = \case
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Maybe Type
extract Type
t
SigT Type
t Type
_ -> Type -> Maybe Type
extract Type
t
ParensT Type
t -> Type -> Maybe Type
extract Type
t
Type
t `AppT` VarT Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
InfixT Type
t Name
_ (VarT Name
n) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
UInfixT Type
t Name
_ (VarT Name
n) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Type -> Maybe Type
extract Type
t
ImplicitParamT String
_ Type
t -> Type -> Maybe Type
extract Type
t
#endif
Type
_ -> Maybe Type
forall a. Maybe a
Nothing
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase =
(Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isBase) ([Type] -> [Type])
-> (EffectInfo -> [Type]) -> EffectInfo -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> [Type]
superEffects
where
isBase :: Type -> Bool
isBase = \case
ConT Name
n -> Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [''Applicative, ''Functor, ''Monad, ''MonadIO]
Type
_ -> Bool
False
data TaggedInfo = TaggedInfo
{ TaggedInfo -> TyVarBndr
tgTag :: TyVarBndr
, TaggedInfo -> [TyVarBndr]
tgParams :: [TyVarBndr]
}
taggedInfo :: EffectInfo -> Q TaggedInfo
taggedInfo :: EffectInfo -> Q TaggedInfo
taggedInfo EffectInfo
info =
case EffectInfo -> [TyVarBndr]
effParams EffectInfo
info of
[] -> String -> Q TaggedInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The effect has no tag parameter."
(TyVarBndr
v:[TyVarBndr]
vs) -> TaggedInfo -> Q TaggedInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaggedInfo -> Q TaggedInfo) -> TaggedInfo -> Q TaggedInfo
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> [TyVarBndr] -> TaggedInfo
TaggedInfo TyVarBndr
v [TyVarBndr]
vs
makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect Name
className = do
EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
Dec
fInstance <- EffectInfo -> Q Dec
finder EffectInfo
effInfo
Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
Dec
tInstance <- EffectInfo -> Q Dec
identityTaggerInstance EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance, Dec
fInstance, Dec
lInstance, Dec
tInstance]
makeTagger :: Name -> Q [Dec]
makeTagger :: Name -> Q [Dec]
makeTagger = (String -> Q String) -> Name -> Q [Dec]
makeTaggerWith String -> Q String
removeApostrophe
makeTaggerWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggerWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggerWith String -> Q String
mapping Name
className = do
let f :: Name -> Q Name
f = (String -> Name) -> Q String -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (Q String -> Q Name) -> (Name -> Q String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q String
mapping (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
TaggedInfo
tagInfo <- EffectInfo -> Q TaggedInfo
taggedInfo EffectInfo
effInfo
(Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
makeTaggedEffect :: Name -> Q [Dec]
makeTaggedEffect :: Name -> Q [Dec]
makeTaggedEffect = (String -> Q String) -> Name -> Q [Dec]
makeTaggedEffectWith String -> Q String
removeApostrophe
makeTaggedEffectWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggedEffectWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggedEffectWith String -> Q String
mapping Name
className = do
let f :: Name -> Q Name
f = (String -> Name) -> Q String -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (Q String -> Q Name) -> (Name -> Q String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q String
mapping (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
TaggedInfo
tagInfo <- EffectInfo -> Q TaggedInfo
taggedInfo EffectInfo
effInfo
Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
Dec
fInstance <- EffectInfo -> Q Dec
finder EffectInfo
effInfo
Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
[Dec]
taggerDecs <- (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
hInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
fInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
lInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
taggerDecs)
makeUntagged :: [Name] -> Q [Dec]
makeUntagged :: [Name] -> Q [Dec]
makeUntagged = (String -> Q String) -> [Name] -> Q [Dec]
makeUntaggedWith String -> Q String
removeApostrophe
makeUntaggedWith :: (String -> Q String) -> [Name] -> Q [Dec]
makeUntaggedWith :: (String -> Q String) -> [Name] -> Q [Dec]
makeUntaggedWith String -> Q String
mapping [Name]
names =
let f :: Name -> Q Name
f = (String -> Name) -> Q String -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (Q String -> Q Name) -> (Name -> Q String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q String
mapping (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase in
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Name] -> (Name -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names ((Name -> Q [Dec]) -> Q [[Dec]]) -> (Name -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
Info
info <- Name -> Q Info
reify Name
name
case Info
info of
VarI Name
funName Type
typ Maybe Dec
_ -> do
Name
tag <- Type -> Q Name
findTagParameter Type
typ
Name
genName <- Name -> Q Name
f Name
funName
Dec
funSig <- Name -> Q Type -> Q Dec
sigD Name
genName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ (Name -> Q Name) -> Name -> Type -> Q Type
replaceTag Name -> Q Name
f Name
tag Type
typ
[Dec]
funDef <- [d| $(varP genName) = $(varE funName) @G |]
Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
genName Inline
Inline RuleMatch
FunLike Phases
AllPhases
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
Info
other ->
String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Expected a function for name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but encountered: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
other
makeHandler :: Name -> Q [Dec]
makeHandler :: Name -> Q [Dec]
makeHandler Name
className = do
EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance]
makeFinder :: Name -> Q [Dec]
makeFinder :: Name -> Q [Dec]
makeFinder Name
className = do
EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
Dec
fInstance <- EffectInfo -> Q Dec
finder EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
fInstance]
makeLifter :: Name -> Q [Dec]
makeLifter :: Name -> Q [Dec]
makeLifter Name
className = do
EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
lInstance]
tagger :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo = do
[Dec]
taggerFuns <- EffectInfo -> TaggedInfo -> Q [Dec]
taggerFunctions EffectInfo
effInfo TaggedInfo
tagInfo
Dec
untaggedSyn <- (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec
untaggedSynonym Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
[Dec]
untaggedFuns <- (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
untaggedFunctions Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
Dec
taggerInst <- EffectInfo -> TaggedInfo -> Q Dec
taggerInstance EffectInfo
effInfo TaggedInfo
tagInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
untaggedSyn
Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
taggerInst
Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
taggerFuns
[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
untaggedFuns
handler :: EffectInfo -> Q Dec
handler :: EffectInfo -> Q Dec
handler EffectInfo
info = do
[Dec]
funs <- EffectInfo -> Q [Dec]
handlerFunctions EffectInfo
info
Name
others <- String -> Q Name
newName String
"others"
Name
trafo <- String -> Q Name
newName String
"t"
CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
( Name -> Name -> CxtQ
instanceHandleCxt Name
others Name
trafo )
( Q Type -> Name -> EffectInfo -> Q Type
instanceHead (Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
others) Name
trafo EffectInfo
info )
( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
where
instanceHandleCxt :: Name -> Name -> Q Cxt
instanceHandleCxt :: Name -> Name -> CxtQ
instanceHandleCxt Name
others Name
trafo = [Q Type] -> CxtQ
cxt
[
Name -> Q Type
conT ''Handle
Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList ((Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Q Type]) -> [Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ EffectInfo -> [Type]
superEffects EffectInfo
info)
Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
others
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
]
finder :: EffectInfo -> Q Dec
finder :: EffectInfo -> Q Dec
finder EffectInfo
info = do
[Dec]
funs <- EffectInfo -> Q [Dec]
finderFunctions EffectInfo
info
Name
other <- String -> Q Name
newName String
"other"
Name
effs <- String -> Q Name
newName String
"effs"
Name
trafo <- String -> Q Name
newName String
"t"
Maybe Overlap -> CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceWithOverlapD
( Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Overlappable )
( Name -> Name -> Name -> CxtQ
instanceFinderCxt Name
other Name
effs Name
trafo )
( Q Type -> Name -> EffectInfo -> Q Type
instanceHead (Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
other Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
effs) Name
trafo EffectInfo
info )
( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
where
instanceFinderCxt :: Name -> Name -> Name -> Q Cxt
instanceFinderCxt :: Name -> Name -> Name -> CxtQ
instanceFinderCxt Name
other Name
effs Name
trafo = [Q Type] -> CxtQ
cxt
[
Name -> Q Type
conT ''Find
Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList ((Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Q Type]) -> [Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ EffectInfo -> [Type]
superEffects EffectInfo
info)
Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
other
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
effs
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
]
lifter :: EffectInfo -> Q Dec
lifter :: EffectInfo -> Q Dec
lifter EffectInfo
info = do
let
monad :: TyVarBndr
monad = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
liftType :: Name
liftType =
if (Signature -> Bool) -> [Signature] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
monad) (EffectInfo -> [Signature]
effMethods EffectInfo
info)
then ''Control
else ''Lift
[Dec]
funs <- EffectInfo -> Q [Dec]
lifterFunctions EffectInfo
info
Name
trafo <- String -> Q Name
newName String
"t"
CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
( Name -> Name -> CxtQ
instanceLiftControlCxt Name
liftType Name
trafo )
( Q Type -> Name -> EffectInfo -> Q Type
instanceHead Q Type
promotedNilT Name
trafo EffectInfo
info )
( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
where
instanceLiftControlCxt :: Name -> Name -> Q Cxt
instanceLiftControlCxt :: Name -> Name -> CxtQ
instanceLiftControlCxt Name
name Name
trafo = [Q Type] -> CxtQ
cxt
[
Name -> Q Type
conT Name
name
Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList ((Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Q Type]) -> [Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ EffectInfo -> [Type]
superEffects EffectInfo
info)
Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
]
instanceHead :: Q Type -> Name -> EffectInfo -> Q Type
instanceHead :: Q Type -> Name -> EffectInfo -> Q Type
instanceHead Q Type
effs Name
trafo EffectInfo
info =
EffectInfo -> Q Type
effectType EffectInfo
info
Q Type -> Q Type -> Q Type
`appT` (
Name -> Q Type
conT ''EachVia
Q Type -> Q Type -> Q Type
`appT` Q Type
effs
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
)
taggerFunctions :: EffectInfo -> TaggedInfo -> Q [Dec]
taggerFunctions :: EffectInfo -> TaggedInfo -> Q [Dec]
taggerFunctions EffectInfo
effInfo TaggedInfo
tagInfo = do
let tagVar :: TyVarBndr
tagVar = TaggedInfo -> TyVarBndr
tgTag TaggedInfo
tagInfo
nameString :: String
nameString = Name -> String
nameBase (EffectInfo -> Name
effName EffectInfo
effInfo)
tagFName :: Name
tagFName = String -> Name
mkName (String
"tag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
retagFName :: Name
retagFName = String -> Name
mkName (String
"retag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
untagFName :: Name
untagFName = String -> Name
mkName (String
"untag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
Name
new <- String -> Q Name
newName String
"new"
[Dec]
tagF <- Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
tagFName EffectInfo
effInfo TaggedInfo
tagInfo Maybe TyVarBndr
forall a. Maybe a
Nothing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new)
[Dec]
retagF <- Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
retagFName EffectInfo
effInfo TaggedInfo
tagInfo (TyVarBndr -> Maybe TyVarBndr
forall a. a -> Maybe a
Just TyVarBndr
tagVar) (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new)
[Dec]
untagF <- Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
untagFName EffectInfo
effInfo TaggedInfo
tagInfo (TyVarBndr -> Maybe TyVarBndr
forall a. a -> Maybe a
Just TyVarBndr
tagVar) Maybe Name
forall a. Maybe a
Nothing
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[Dec]
tagF [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
retagF [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
untagF
taggerFunction :: Name -> EffectInfo -> TaggedInfo -> Maybe TyVarBndr -> Maybe Name -> Q [Dec]
taggerFunction :: Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
funName EffectInfo
effInfo TaggedInfo
tagInfo Maybe TyVarBndr
tag Maybe Name
new = do
Name
mName <- String -> Q Name
newName String
"m"
Name
aName <- String -> Q Name
newName String
"a"
Type
gType <- [t| G |]
let m :: Q Type
m = Name -> Q Type
varT Name
mName
a :: Q Type
a = Name -> Q Type
varT Name
aName
params :: [TyVarBndr]
params = TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo
tagParam :: Q Type
tagParam = Q Type -> (TyVarBndr -> Q Type) -> Maybe TyVarBndr -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
gType) (Name -> Q Type
varT (Name -> Q Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarName) Maybe TyVarBndr
tag
newParam :: Q Type
newParam = Q Type -> (Name -> Q Type) -> Maybe Name -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
gType) Name -> Q Type
varT Maybe Name
new
tagVars :: [TyVarBndr]
tagVars = Maybe TyVarBndr -> [TyVarBndr]
forall a. Maybe a -> [a]
maybeToList Maybe TyVarBndr
tag [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ Maybe TyVarBndr -> [TyVarBndr]
forall a. Maybe a -> [a]
maybeToList ((Name -> TyVarBndr) -> Maybe Name -> Maybe TyVarBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr
PlainTV Maybe Name
new)
forallVars :: [TyVarBndr]
forallVars = (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> TyVarBndr
unkindTyVar ([TyVarBndr]
tagVars [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr]
params) [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndr
PlainTV Name
mName, Name -> TyVarBndr
PlainTV Name
aName]
paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyVarBndr -> Q Type
tyVarType (TyVarBndr -> Q Type)
-> (TyVarBndr -> TyVarBndr) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> TyVarBndr
unkindTyVar) [TyVarBndr]
params
effType :: Q Type
effType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
effInfo) (Q Type
tagParam Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes)
effList :: [Q Type]
effList = Q Type
effType Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EffectInfo -> [Type]
superEffectsWithoutBase EffectInfo
effInfo)
untagList :: [Q Type]
untagList =
case Maybe TyVarBndr
tag of
Maybe TyVarBndr
Nothing -> (Q Type -> Q Type) -> [Q Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Type -> Type -> Type
replace (TyVarBndr -> Name
tyVarName (TyVarBndr -> Name) -> TyVarBndr -> Name
forall a b. (a -> b) -> a -> b
$ TaggedInfo -> TyVarBndr
tgTag TaggedInfo
tagInfo) Type
gType)) [Q Type]
effList
Just TyVarBndr
_ -> [Q Type]
effList
taggerType :: Q Type
taggerType = [t| Tagger $tagParam $newParam |]
viaType :: Q Type
viaType =
case [Q Type]
untagList of
#if __GLASGOW_HASKELL__ >= 808
[Q Type
e] -> Q Type -> Name -> Q Type -> Q Type
uInfixT Q Type
e ''Via Q Type
taggerType
[Q Type]
es -> Q Type -> Name -> Q Type -> Q Type
uInfixT ([Q Type] -> Q Type
typeLevelList [Q Type]
es) ''EachVia Q Type
taggerType
#else
[e] -> conT ''Via `appT` e `appT` taggerType
es -> conT ''EachVia `appT` typeLevelList es `appT` taggerType
#endif
funSigType :: Q Type
funSigType = [t| $viaType $m $a -> $m $a |]
Dec
funSig <- Name -> Q Type -> Q Dec
sigD Name
funName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT [TyVarBndr]
forallVars ([Q Type] -> CxtQ
cxt []) Q Type
funSigType
[Dec]
funDef <- [d| $(varP funName) = runTagger . runVia |]
Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
where
replace :: Name -> Type -> Type -> Type
replace :: Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag = \case
ConT Name
n `AppT` VarT Name
param | Name
param Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
oldTag -> Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
newTag
ForallT [TyVarBndr]
vars [Type]
ctx Type
t -> [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
vars [Type]
ctx (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t)
AppT Type
l Type
r -> Type -> Type -> Type
AppT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
l) Type
r
SigT Type
t Type
k -> Type -> Type -> Type
SigT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t) Type
k
InfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
InfixT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
l) Name
n (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
r)
UInfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
UInfixT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
l) Name
n (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
r)
ParensT Type
t -> Type -> Type
ParensT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t)
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
k -> Type -> Type -> Type
AppKindT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t) Type
k
ImplicitParamT String
s Type
t -> String -> Type -> Type
ImplicitParamT String
s (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t)
#endif
Type
other -> Type
other
untaggedSynonym :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec
untaggedSynonym :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec
untaggedSynonym Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo = do
Name
synName <- Name -> Q Name
f (EffectInfo -> Name
effName EffectInfo
effInfo)
Name -> [TyVarBndr] -> Q Type -> Q Dec
tySynD
( Name
synName )
( [TyVarBndr]
params )
( (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
effInfo) (Name -> Q Type
conT ''G Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType [TyVarBndr]
params) )
where
params :: [TyVarBndr]
params = (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> TyVarBndr
unkindTyVar (TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo)
untaggedFunctions :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
untaggedFunctions :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
untaggedFunctions Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo = do
Name
synName <- Name -> Q Name
f (EffectInfo -> Name
effName EffectInfo
effInfo)
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
effInfo)
((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]
untaggedFunction Name -> Q Name
f
(Q Type -> Signature -> Q [Dec]) -> Q Type -> Signature -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
( Q Type -> Q Type -> Q Type
appT )
( Name -> Q Type
conT Name
synName )
( (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyVarBndr -> Q Type
tyVarType (TyVarBndr -> Q Type)
-> (TyVarBndr -> TyVarBndr) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> TyVarBndr
unkindTyVar) ([TyVarBndr] -> [Q Type]) -> [TyVarBndr] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [EffectInfo -> TyVarBndr
effMonad EffectInfo
effInfo] )
untaggedFunction :: (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]
untaggedFunction :: (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]
untaggedFunction Name -> Q Name
f Q Type
effType Signature
sig = do
let originalName :: Name
originalName = Signature -> Name
sigName Signature
sig
signatureBody :: Q Type
signatureBody = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type
unkindType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Signature -> Type
sigType Signature
sig)
Name
funName <- Name -> Q Name
f Name
originalName
Dec
funSig <- Name -> Q Type -> Q Dec
sigD Name
funName [t| $effType => $signatureBody |]
[Dec]
funDef <- [d| $(varP funName) = $(varE originalName) @G |]
Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
taggerInstance :: EffectInfo -> TaggedInfo -> Q Dec
taggerInstance :: EffectInfo -> TaggedInfo -> Q Dec
taggerInstance EffectInfo
effInfo TaggedInfo
tagInfo = do
Name
newTagName <- String -> Q Name
newName String
"new"
let new :: Q Type
new = Name -> Q Type
varT Name
newTagName
monadName :: Name
monadName = TyVarBndr -> Name
tyVarName (EffectInfo -> TyVarBndr
effMonad EffectInfo
effInfo)
m :: Q Type
m = Name -> Q Type
varT Name
monadName
tag :: Q Type
tag = TyVarBndr -> Q Type
tyVarType (TaggedInfo -> TyVarBndr
tgTag TaggedInfo
tagInfo)
effType :: Q Type
effType = Name -> Q Type
conT (EffectInfo -> Name
effName EffectInfo
effInfo)
paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType (TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo)
taggerType :: Q Type
taggerType = [t| Tagger $tag $new $m |]
cxtParams :: [Q Type]
cxtParams = Q Type
new Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
m]
headParams :: [Q Type]
headParams = Q Type
tag Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
taggerType]
[Dec]
funs <-
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
effInfo) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ Q Type -> Name -> Signature -> Q [Dec]
taggerInstanceFunction Q Type
new Name
monadName
CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
( [Q Type] -> CxtQ
cxt [(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
cxtParams] )
( (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
headParams )
( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
taggerInstanceFunction :: Q Type -> Name -> Signature -> Q [Dec]
taggerInstanceFunction :: Q Type -> Name -> Signature -> Q [Dec]
taggerInstanceFunction Q Type
new Name
monad Signature
sig = do
let typ :: Type
typ = Signature -> Type
sigType Signature
sig
funName :: Name
funName = Signature -> Name
sigName Signature
sig
expr :: Q Exp
expr = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [] [| Tagger |] [| runTagger |] Name
monad Type
typ
typeAppliedName :: Q Exp
typeAppliedName = Name -> Q Exp
varE Name
funName Q Exp -> Q Type -> Q Exp
`appTypeE` Q Type
new
[Dec]
funDef <- [d| $(varP funName) = $expr $typeAppliedName |]
Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
identityTaggerInstance :: EffectInfo -> Q Dec
identityTaggerInstance :: EffectInfo -> Q Dec
identityTaggerInstance EffectInfo
info = do
Name
oldTagName <- String -> Q Name
newName String
"tag"
Name
newTagName <- String -> Q Name
newName String
"new"
let old :: Q Type
old = Name -> Q Type
varT Name
oldTagName
new :: Q Type
new = Name -> Q Type
varT Name
newTagName
monadName :: Name
monadName = TyVarBndr -> Name
tyVarName (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
m :: Q Type
m = Name -> Q Type
varT Name
monadName
effType :: Q Type
effType = Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info
paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info)
taggerType :: Q Type
taggerType = [t| Tagger $old $new $m |]
cxtParams :: [Q Type]
cxtParams = [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
m]
headParams :: [Q Type]
headParams = [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
taggerType]
[Dec]
funs <-
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
info) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| Tagger |] [| runTagger |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info)
CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
( [Q Type] -> CxtQ
cxt [(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
cxtParams] )
( (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
headParams )
( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions EffectInfo
info =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
(Signature -> Q [Dec]) -> [Signature] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
( Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| EachVia |] [| runVia |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
( EffectInfo -> [Signature]
effMethods EffectInfo
info )
finderFunctions :: EffectInfo -> Q [Dec]
finderFunctions :: EffectInfo -> Q [Dec]
finderFunctions EffectInfo
info =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
(Signature -> Q [Dec]) -> [Signature] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
( Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| liftL |] [| runL |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
( EffectInfo -> [Signature]
effMethods EffectInfo
info )
lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions EffectInfo
info =
let m :: TyVarBndr
m = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
params :: [TyVarBndr]
params = EffectInfo -> [TyVarBndr]
effParams EffectInfo
info
invalid :: Q a
invalid = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
"Could not generate effect instance because the operation is "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"invalid for higher-order effects."
in
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
info) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Signature
sig ->
if TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
m Signature
sig
then TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
higherFunction TyVarBndr
m [TyVarBndr]
params Signature
sig
else Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| lift |] Q Exp
forall a. Q a
invalid TyVarBndr
m [TyVarBndr]
params Signature
sig
function :: Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function :: Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function Q Exp
f Q Exp
inv TyVarBndr
monad [TyVarBndr]
params Signature
sig = do
let m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
funName :: Name
funName = Signature -> Name
sigName Signature
sig
paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType [TyVarBndr]
params
typeAppliedName :: Q Exp
typeAppliedName = (Q Exp -> Q Type -> Q Exp) -> Q Exp -> [Q Type] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Type -> Q Exp
appTypeE (Name -> Q Exp
varE Name
funName) [Q Type]
paramTypes
expr :: Q Exp
expr = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [] Q Exp
f Q Exp
inv Name
m (Signature -> Type
sigType Signature
sig)
[Dec]
funDef <- [d| $(varP funName) = $expr $typeAppliedName |]
Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
higherFunction :: TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
higherFunction :: TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
higherFunction TyVarBndr
monad [TyVarBndr]
params Signature
sig = do
let m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
typ :: Type
typ = Signature -> Type
sigType Signature
sig
funName :: Name
funName = Signature -> Name
sigName Signature
sig
paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType [TyVarBndr]
params
restores :: [Type]
restores = Bool -> Name -> Type -> [Type]
restorables Bool
False Name
m Type
typ
expr :: Q Exp
expr = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
restores [| id |] [| run . runVia |] Name
m Type
typ
[Name]
fParams <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Type -> Int
paramCount Type
typ) (String -> Q Name
newName String
"x")
Type
resType <- Name -> Type -> Q Type
resultType Name
m Type
typ
let typeAppliedName :: Q Exp
typeAppliedName = (Q Exp -> Q Type -> Q Exp) -> Q Exp -> [Q Type] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Type -> Q Exp
appTypeE (Name -> Q Exp
varE Name
funName) [Q Type]
paramTypes
appliedExp :: Q Exp
appliedExp = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE Q Exp
expr (Q Exp
typeAppliedName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Q Exp
varE [Name]
fParams)
body :: Q Exp
body =
[| EachVia $
(liftWith $ \ $([p|run|]) -> $appliedExp)
>>= $(traverseExp resType) (restoreT . pure)
|]
Dec
funDef <- Name -> [ClauseQ] -> Q Dec
funD Name
funName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause ((Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> PatQ
varP [Name]
fParams) (Q Exp -> BodyQ
normalB Q Exp
body) []]
Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
funDef, Dec
funInline]
where
restorables :: Bool -> Name -> Type -> [Type]
restorables :: Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m = \case
VarT Name
n `AppT` Type
a
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
&& Bool
neg -> [Type
a]
Type
ArrowT `AppT` Type
a `AppT` Type
r -> Bool -> Name -> Type -> [Type]
restorables (Bool -> Bool
not Bool
neg) Name
m Type
a [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
r
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
SigT Type
t Type
_ -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
ParensT Type
t -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
ImplicitParamT String
_ Type
t -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
#endif
Type
other -> String -> [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$ String
"Encountered an unknown term when finding restorables: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
other
traverseExp :: Type -> Q Exp
traverseExp :: Type -> Q Exp
traverseExp = \case
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Q Exp
traverseExp Type
t
AppT Type
_ Type
r -> Type -> Q Exp
traverseRec Type
r
SigT Type
t Type
_ -> Type -> Q Exp
traverseExp Type
t
InfixT Type
_ Name
_ Type
r -> Type -> Q Exp
traverseRec Type
r
UInfixT Type
_ Name
_ Type
r -> Type -> Q Exp
traverseRec Type
r
ParensT Type
t -> Type -> Q Exp
traverseExp Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Type -> Q Exp
traverseExp Type
t
ImplicitParamT String
_ Type
t -> Type -> Q Exp
traverseExp Type
t
#endif
Type
_ -> [| id |]
where
traverseRec :: Type -> Q Exp
traverseRec Type
t = [| traverse . $(traverseExp t) |]
derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m = \case
Type
t | Bool -> Bool
not (Name -> Type -> Bool
contains Name
m Type
t) ->
[| id |]
VarT Name
n `AppT` Type
_ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m ->
Q Exp
f
Type
ArrowT `AppT` Type
arg `AppT` Type
res ->
let rf :: Q Exp
rf = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
res
af :: Q Exp
af = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
inv Q Exp
f Name
m Type
arg
in if Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
arg [Type]
rs
then [| \x b -> $rf (((x =<<) . EachVia . restoreT . pure) b) |]
else [| \x b -> $rf (x ($af b)) |]
ForallT [TyVarBndr]
_ [Type]
_ Type
t ->
[Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ ->
[Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
t
ImplicitParamT String
_ Type
t ->
[Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
t
#endif
Type
other -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Could not generate effect instance because an unknown structure "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"was encountered: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
other
unkindType :: Type -> Type
unkindType :: Type -> Type
unkindType = \case
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Type
unkindType Type
t
AppT Type
l Type
r -> Type -> Type -> Type
AppT (Type -> Type
unkindType Type
l) (Type -> Type
unkindType Type
r)
SigT Type
t Type
_ -> Type
t
InfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
InfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
UInfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
UInfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
ParensT Type
t -> Type -> Type
ParensT (Type -> Type
unkindType Type
t)
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Type -> Type
unkindType Type
t
ImplicitParamT String
s Type
t -> String -> Type -> Type
ImplicitParamT String
s (Type -> Type
unkindType Type
t)
#endif
Type
other -> Type
other
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar (KindedTV Name
n Type
_) = Name -> TyVarBndr
PlainTV Name
n
unkindTyVar TyVarBndr
unkinded = TyVarBndr
unkinded
tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV Name
n ) = Name
n
tyVarName (KindedTV Name
n Type
_) = Name
n
tyVarType :: TyVarBndr -> Q Type
tyVarType :: TyVarBndr -> Q Type
tyVarType (PlainTV Name
n ) = Name -> Q Type
varT Name
n
tyVarType (KindedTV Name
n Type
k) = Q Type -> Type -> Q Type
sigT (Name -> Q Type
varT Name
n) Type
k
paramCount :: Type -> Int
paramCount :: Type -> Int
paramCount = \case
Type
ArrowT `AppT` Type
_ `AppT` Type
r -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
paramCount Type
r
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Int
paramCount Type
t
Type
_ -> Int
0
liftL :: EachVia effs t m a -> EachVia (eff : effs) t m a
liftL :: EachVia effs t m a -> EachVia (eff : effs) t m a
liftL = EachVia effs t m a -> EachVia (eff : effs) t m a
coerce
{-# INLINE liftL #-}
runL :: EachVia (eff : effs) t m a -> EachVia effs t m a
runL :: EachVia (eff : effs) t m a -> EachVia effs t m a
runL = EachVia (eff : effs) t m a -> EachVia effs t m a
coerce
{-# INLINE runL #-}
removeApostrophe :: String -> Q String
removeApostrophe :: String -> Q String
removeApostrophe String
name =
if String
"'" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
name then
String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
init String
name
else
String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ String
"Tagged effect and function names are expected to end with \"'\"."
typeLevelList :: [Q Type] -> Q Type
typeLevelList :: [Q Type] -> Q Type
typeLevelList [] = Q Type
promotedNilT
typeLevelList (Q Type
t:[Q Type]
ts) = Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList [Q Type]
ts
resultType :: Name -> Type -> Q Type
resultType :: Name -> Type -> Q Type
resultType Name
m = \case
VarT Name
n `AppT` Type
a | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a
Type
ArrowT `AppT` Type
_ `AppT` Type
r -> Name -> Type -> Q Type
resultType Name
m Type
r
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Name -> Type -> Q Type
resultType Name
m Type
t
SigT Type
t Type
_ -> Name -> Type -> Q Type
resultType Name
m Type
t
ParensT Type
t -> Name -> Type -> Q Type
resultType Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Name -> Type -> Q Type
resultType Name
m Type
t
ImplicitParamT String
_ Type
t -> Name -> Type -> Q Type
resultType Name
m Type
t
#endif
Type
other -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Expected a return type of the form 'm a', but encountered: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
other
contains :: Name -> Type -> Bool
contains :: Name -> Type -> Bool
contains Name
m = \case
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Name -> Type -> Bool
contains Name
m Type
t
AppT Type
l Type
r -> Name -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
SigT Type
t Type
_ -> Name -> Type -> Bool
contains Name
m 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 -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m 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 -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
ParensT Type
t -> Name -> Type -> Bool
contains Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Name -> Type -> Bool
contains Name
m Type
t
ImplicitParamT String
_ Type
t -> Name -> Type -> Bool
contains Name
m Type
t
#endif
Type
_ -> Bool
False
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType TyVarBndr
monad = Bool -> Type -> Bool
go Bool
False
where
m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
go :: Bool -> Type -> Bool
go Bool
negPos = \case
VarT Name
n `AppT` Type
_ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Bool
negPos
Type
ArrowT `AppT` Type
a `AppT` Type
r ->
Bool -> Type -> Bool
go (Bool -> Bool
not Bool
negPos) Type
a Bool -> Bool -> Bool
|| Bool -> Type -> Bool
go Bool
negPos Type
r
ForallT [TyVarBndr]
_ [Type]
_ Type
t ->
Bool -> Type -> Bool
go Bool
negPos Type
t
Type
_ ->
Bool
False
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
monad = TyVarBndr -> Type -> Bool
isHigherType TyVarBndr
monad (Type -> Bool) -> (Signature -> Type) -> Signature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> Type
sigType
findTagParameter :: Type -> Q Name
findTagParameter :: Type -> Q Name
findTagParameter Type
typ =
case Type -> Maybe Name
go Type
typ of
Just Name
n -> Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
Maybe Name
Nothing ->
String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Cannot find the tag parameter of the type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
typ
where
go :: Type -> Maybe Name
go :: Type -> Maybe Name
go = \case
ForallT [TyVarBndr]
tyVars [Type]
ctx Type
t ->
case (TyVarBndr -> Bool) -> [TyVarBndr] -> [TyVarBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyVarBndr -> Bool) -> TyVarBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Bool
isStar) [TyVarBndr]
tyVars of
(TyVarBndr
v:[TyVarBndr]
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
v
[] ->
case [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes ((Type -> Maybe Name) -> [Type] -> [Maybe Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Maybe Name
go [Type]
ctx) of
(Name
n:[Name]
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
[] -> Type -> Maybe Name
go Type
t
AppT Type
l Type
r ->
case Type -> Maybe Name
go Type
l of
Just Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
Maybe Name
Nothing -> Type -> Maybe Name
go Type
r
SigT Type
t Type
_ -> Type -> Maybe Name
go Type
t
VarT Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
InfixT Type
l Name
_ Type
r ->
case Type -> Maybe Name
go Type
l of
Just Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
Maybe Name
Nothing -> Type -> Maybe Name
go Type
r
UInfixT Type
l Name
_ Type
r ->
case Type -> Maybe Name
go Type
l of
Just Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
Maybe Name
Nothing -> Type -> Maybe Name
go Type
r
ParensT Type
t -> Type -> Maybe Name
go Type
t
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
_ -> Type -> Maybe Name
go Type
t
ImplicitParamT String
_ Type
t -> Type -> Maybe Name
go Type
t
#endif
Type
_ -> Maybe Name
forall a. Maybe a
Nothing
isStar :: TyVarBndr -> Bool
isStar :: TyVarBndr -> Bool
isStar (PlainTV Name
_) = Bool
True
isStar (KindedTV Name
_ Type
StarT) = Bool
True
isStar TyVarBndr
_ = Bool
False
replaceTag :: (Name -> Q Name) -> Name -> Type -> Q Type
replaceTag :: (Name -> Q Name) -> Name -> Type -> Q Type
replaceTag Name -> Q Name
f Name
tag = \case
ForallT [TyVarBndr]
_tyVars [Type]
cxts Type
t -> Type -> Q Type
go ([TyVarBndr] -> [Type] -> Type -> Type
ForallT [] [Type]
cxts Type
t)
Type
other -> Type -> Q Type
go Type
other
where
go :: Type -> Q Type
go = \case
ForallT [TyVarBndr]
tyVars [Type]
cxts Type
t ->
[TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT
( (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> TyVarBndr
unkindTyVar [TyVarBndr]
tyVars )
( [Q Type] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> CxtQ) -> [Q Type] -> CxtQ
forall a b. (a -> b) -> a -> b
$ (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
go [Type]
cxts )
( Type -> Q Type
go Type
t )
#if __GLASGOW_HASKELL__ >= 808
ConT Name
n `AppT` Type
eff `AppT` Type
t | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Via Bool -> Bool -> Bool
|| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''EachVia ->
Type -> Q Type
go (Type -> Name -> Type -> Type
UInfixT Type
eff Name
n Type
t)
#endif
ConT Name
n `AppT` VarT Name
t | Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tag ->
Name -> Q Name
f Name
n Q Name -> (Name -> Q Type) -> Q Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Q Type
conT
AppT Type
l Type
r ->
Q Type -> Q Type -> Q Type
appT (Type -> Q Type
go Type
l) (Type -> Q Type
go Type
r)
SigT Type
t Type
_ ->
Type -> Q Type
go Type
t
VarT Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tag -> Name -> Q Type
conT ''G
| Bool
otherwise -> Name -> Q Type
varT Name
n
InfixT Type
l Name
n Type
r ->
Q Type -> Name -> Q Type -> Q Type
infixT (Type -> Q Type
go Type
l) Name
n (Type -> Q Type
go Type
r)
UInfixT Type
l Name
n Type
r ->
Q Type -> Name -> Q Type -> Q Type
uInfixT (Type -> Q Type
go Type
l) Name
n (Type -> Q Type
go Type
r)
ParensT Type
t ->
Q Type -> Q Type
parensT (Type -> Q Type
go Type
t)
#if __GLASGOW_HASKELL__ >= 808
AppKindT Type
t Type
k ->
Q Type -> Q Type -> Q Type
appKindT (Type -> Q Type
go Type
t) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
k)
ImplicitParamT String
s Type
t ->
String -> Q Type -> Q Type
implicitParamT String
s (Type -> Q Type
go Type
t)
#endif
Type
other ->
Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other