{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Machinery.TH
(
makeEffect
, makeHandler
, makeLifter
, makeTaggedEffect
, makeTaggedEffectWith
, makeTagger
, makeTaggerWith
, removeApostrophe
) where
import Control.Monad (forM, replicateM)
import Data.List (isSuffixOf)
import Data.Maybe (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.Kind (Control, Handle, Lift)
import Control.Effect.Machinery.Tagger (Tagger, runTagger)
import Control.Effect.Machinery.Via (G, Via(Via), runVia)
data ClassInfo = ClassInfo
{ ClassInfo -> Cxt
clsCxt :: Cxt
, ClassInfo -> Name
clsName :: Name
, ClassInfo -> [TyVarBndr]
clsTyVars :: [TyVarBndr]
, ClassInfo -> [FunDep]
_clsFunDeps :: [FunDep]
, ClassInfo -> [Dec]
clsDecs :: [Dec]
}
data EffectInfo = EffectInfo
{ EffectInfo -> Cxt
_effCxt :: Cxt
, EffectInfo -> Q Type
effType :: Q Type
, EffectInfo -> [TyVarBndr]
effParams :: [TyVarBndr]
, EffectInfo -> TyVarBndr
effMonad :: TyVarBndr
, EffectInfo -> Name
effName :: Name
, EffectInfo -> Name
effTrafoName :: Name
, EffectInfo -> [Signature]
effSigs :: [Signature]
}
data TaggedInfo = TaggedInfo
{ TaggedInfo -> TyVarBndr
tgTag :: TyVarBndr
, TaggedInfo -> [TyVarBndr]
tgParams :: [TyVarBndr]
, TaggedInfo -> TyVarBndr
tgMonad :: TyVarBndr
, TaggedInfo -> Name
tgEffName :: Name
, TaggedInfo -> String -> Q String
tgNameMap :: String -> Q String
, TaggedInfo -> [Signature]
tgSigs :: [Signature]
}
data Signature = Signature
{ Signature -> Name
sigName :: Name
, Signature -> Type
sigType :: Type
}
synonymName :: TaggedInfo -> Q Name
synonymName :: TaggedInfo -> Q Name
synonymName info :: TaggedInfo
info = (String -> Q String) -> Name -> Q Name
mapName (TaggedInfo -> String -> Q String
tgNameMap TaggedInfo
info) (TaggedInfo -> Name
tgEffName TaggedInfo
info)
resultType :: Name -> Type -> Q Type
resultType :: Name -> Type -> Q Type
resultType m :: Name
m typ :: Type
typ =
case Type
typ of
VarT n :: Name
n `AppT` a :: 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
ArrowT `AppT` _ `AppT` r :: Type
r -> Name -> Type -> Q Type
resultType Name
m Type
r
ForallT _ _ t :: Type
t -> Name -> Type -> Q Type
resultType Name
m Type
t
SigT t :: Type
t _ -> Name -> Type -> Q Type
resultType Name
m Type
t
ParensT t :: Type
t -> Name -> Type -> Q Type
resultType Name
m Type
t
other :: 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
$ "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
restorables :: Bool -> Name -> Type -> [Type]
restorables :: Bool -> Name -> Type -> Cxt
restorables neg :: Bool
neg m :: Name
m typ :: Type
typ =
case Type
typ of
VarT n :: Name
n `AppT` a :: Type
a | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
&& Bool
neg -> [Type
a]
ArrowT `AppT` a :: Type
a `AppT` r :: Type
r -> Bool -> Name -> Type -> Cxt
restorables (Bool -> Bool
not Bool
neg) Name
m Type
a Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
r
ForallT _ _ t :: Type
t -> Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
t
SigT t :: Type
t _ -> Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
t
ParensT t :: Type
t -> Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
t
other :: Type
other -> String -> Cxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Cxt) -> String -> Cxt
forall a b. (a -> b) -> a -> b
$ "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
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType monad :: TyVarBndr
monad = Bool -> Type -> Bool
go Bool
False
where
m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
go :: Bool -> Type -> Bool
go negPos :: Bool
negPos typ :: Type
typ =
case Type
typ of
VarT n :: Name
n `AppT` _ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Bool
negPos
ArrowT `AppT` a :: Type
a `AppT` r :: 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 _ _ t :: Type
t ->
Bool -> Type -> Bool
go Bool
negPos Type
t
_ ->
Bool
False
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder monad :: 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
signature :: Dec -> Q Signature
signature :: Dec -> Q Signature
signature dec :: Dec
dec =
case Dec
dec of
SigD name :: Name
name typ :: Type
typ ->
Signature -> Q Signature
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type -> Signature
Signature Name
name Type
typ)
other :: Dec
other ->
String -> Q Signature
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q Signature) -> String -> Q Signature
forall a b. (a -> b) -> a -> b
$ "The generation of the effect handling machinery currently supports"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " only signatures, but encountered: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
other
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar (KindedTV n :: Name
n _) = Name -> TyVarBndr
PlainTV Name
n
unkindTyVar unkinded :: TyVarBndr
unkinded = TyVarBndr
unkinded
tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV n :: Name
n ) = Name
n
tyVarName (KindedTV n :: Name
n _) = Name
n
tyVarType :: TyVarBndr -> Q Type
tyVarType :: TyVarBndr -> Q Type
tyVarType (PlainTV n :: Name
n ) = Name -> Q Type
varT Name
n
tyVarType (KindedTV n :: Name
n k :: Type
k) = Q Type -> Type -> Q Type
sigT (Name -> Q Type
varT Name
n) Type
k
effectVars :: ClassInfo -> Q ([TyVarBndr], TyVarBndr)
effectVars :: ClassInfo -> Q ([TyVarBndr], TyVarBndr)
effectVars info :: ClassInfo
info =
case ClassInfo -> [TyVarBndr]
clsTyVars ClassInfo
info 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
$ "The specified effect type class `"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (ClassInfo -> Name
clsName ClassInfo
info)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' has no monad type variable. "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "It is expected to be the last type variable."
vs :: [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)
effectInfo :: ClassInfo -> Q EffectInfo
effectInfo :: ClassInfo -> Q EffectInfo
effectInfo info :: ClassInfo
info = do
(params :: [TyVarBndr]
params, clsM :: TyVarBndr
clsM) <- ClassInfo -> Q ([TyVarBndr], TyVarBndr)
effectVars ClassInfo
info
Name
t <- String -> Q Name
newName "t"
[Signature]
sigs <- (Dec -> Q Signature) -> [Dec] -> Q [Signature]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q Signature
signature (ClassInfo -> [Dec]
clsDecs ClassInfo
info)
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
$
Cxt
-> Q Type
-> [TyVarBndr]
-> TyVarBndr
-> Name
-> Name
-> [Signature]
-> EffectInfo
EffectInfo
( ClassInfo -> Cxt
clsCxt ClassInfo
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
$ ClassInfo -> Name
clsName ClassInfo
info) ((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) )
( [TyVarBndr]
params )
( TyVarBndr
clsM )
( ClassInfo -> Name
clsName ClassInfo
info )
( Name
t )
( [Signature]
sigs )
extractTag :: [TyVarBndr] -> Q (TyVarBndr, [TyVarBndr])
[] = String -> Q (TyVarBndr, [TyVarBndr])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "The effect has no tag parameter."
extractTag (v :: TyVarBndr
v:vs :: [TyVarBndr]
vs) = (TyVarBndr, [TyVarBndr]) -> Q (TyVarBndr, [TyVarBndr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr
v, [TyVarBndr]
vs)
removeApostrophe :: String -> Q String
removeApostrophe :: String -> Q String
removeApostrophe name :: String
name =
if "'" 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
$ "Tagged effect and function names are expected to end with \"'\"."
mapName :: (String -> Q String) -> Name -> Q Name
mapName :: (String -> Q String) -> Name -> Q Name
mapName f :: String -> Q String
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
f (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
taggedInfo :: (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo :: (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo f :: String -> Q String
f info :: EffectInfo
info = do
(tag :: TyVarBndr
tag, params :: [TyVarBndr]
params) <- [TyVarBndr] -> Q (TyVarBndr, [TyVarBndr])
extractTag (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info)
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]
-> TyVarBndr
-> Name
-> (String -> Q String)
-> [Signature]
-> TaggedInfo
TaggedInfo
( TyVarBndr
tag )
( [TyVarBndr]
params )
( EffectInfo -> TyVarBndr
effMonad EffectInfo
info )
( EffectInfo -> Name
effName EffectInfo
info )
( String -> Q String
f )
( EffectInfo -> [Signature]
effSigs EffectInfo
info )
classInfo :: Name -> Q ClassInfo
classInfo :: Name -> Q ClassInfo
classInfo className :: Name
className = do
Info
info <- Name -> Q Info
reify Name
className
case Info
info of
ClassI (ClassD context :: Cxt
context name :: Name
name tyVars :: [TyVarBndr]
tyVars funDeps :: [FunDep]
funDeps decs :: [Dec]
decs) _ ->
ClassInfo -> Q ClassInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Dec] -> ClassInfo
ClassInfo Cxt
context Name
name [TyVarBndr]
tyVars [FunDep]
funDeps [Dec]
decs)
other :: Info
other ->
String -> Q ClassInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q ClassInfo) -> String -> Q ClassInfo
forall a b. (a -> b) -> a -> b
$ "The specified name `"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' 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
instanceCxt :: Name -> EffectInfo -> Q Cxt
instanceCxt :: Name -> EffectInfo -> Q Cxt
instanceCxt name :: Name
name info :: EffectInfo
info = [Q Type] -> Q Cxt
cxt
[
Name -> Q Type
conT Name
name
Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effType EffectInfo
info
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT (EffectInfo -> Name
effTrafoName EffectInfo
info)
Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
]
instanceHead :: Q Type -> EffectInfo -> Q Type
instanceHead :: Q Type -> EffectInfo -> Q Type
instanceHead eff :: Q Type
eff info :: EffectInfo
info =
EffectInfo -> Q Type
effType EffectInfo
info
Q Type -> Q Type -> Q Type
`appT` (
Name -> Q Type
conT ''Via
Q Type -> Q Type -> Q Type
`appT` Q Type
eff
Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT (EffectInfo -> Name
effTrafoName EffectInfo
info)
Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
)
makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect className :: Name
className = do
ClassInfo
clsInfo <- Name -> Q ClassInfo
classInfo Name
className
EffectInfo
effInfo <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance, Dec
lInstance]
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 f :: String -> Q String
f className :: Name
className = do
ClassInfo
clsInfo <- Name -> Q ClassInfo
classInfo Name
className
EffectInfo
effInfo <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
TaggedInfo
tagInfo <- (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo String -> Q String
f EffectInfo
effInfo
TaggedInfo -> Q [Dec]
tagger 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 f :: String -> Q String
f className :: Name
className = do
ClassInfo
clsInfo <- Name -> Q ClassInfo
classInfo Name
className
EffectInfo
effInfo <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
TaggedInfo
tagInfo <- (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo String -> Q String
f EffectInfo
effInfo
Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
[Dec]
taggerDecs <- TaggedInfo -> Q [Dec]
tagger 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
lInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
taggerDecs)
makeHandler :: Name -> Q [Dec]
makeHandler :: Name -> Q [Dec]
makeHandler className :: Name
className = do
ClassInfo
clsInfo <- Name -> Q ClassInfo
classInfo Name
className
EffectInfo
effInfo <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance]
makeLifter :: Name -> Q [Dec]
makeLifter :: Name -> Q [Dec]
makeLifter className :: Name
className = do
ClassInfo
clsInfo <- Name -> Q ClassInfo
classInfo Name
className
EffectInfo
effInfo <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
lInstance]
tagger :: TaggedInfo -> Q [Dec]
tagger :: TaggedInfo -> Q [Dec]
tagger info :: TaggedInfo
info = do
[Dec]
taggerFuns <- TaggedInfo -> Q [Dec]
taggerFunctions TaggedInfo
info
Dec
untaggedSyn <- TaggedInfo -> Q Dec
untaggedSynonym TaggedInfo
info
[Dec]
untaggedFuns <- TaggedInfo -> Q [Dec]
untaggedFunctions TaggedInfo
info
Dec
taggerInst <- TaggedInfo -> Q Dec
taggerInstance TaggedInfo
info
[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 info :: EffectInfo
info = do
[Dec]
funs <- EffectInfo -> Q [Dec]
handlerFunctions EffectInfo
info
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceD
( Name -> EffectInfo -> Q Cxt
instanceCxt ''Handle EffectInfo
info )
( Q Type -> EffectInfo -> Q Type
instanceHead (EffectInfo -> Q Type
effType EffectInfo
info) 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 )
lifter :: EffectInfo -> Q Dec
lifter :: EffectInfo -> Q Dec
lifter info :: EffectInfo
info = do
let
monad :: TyVarBndr
monad = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
context :: Name
context =
if (Signature -> Bool) -> [Signature] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
monad) (EffectInfo -> [Signature]
effSigs EffectInfo
info)
then ''Control
else ''Lift
[Dec]
funs <- EffectInfo -> Q [Dec]
lifterFunctions EffectInfo
info
Name
eff <- String -> Q Name
newName "eff"
Maybe Overlap -> Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceWithOverlapD
( Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Overlappable )
( Name -> EffectInfo -> Q Cxt
instanceCxt Name
context EffectInfo
info )
( Q Type -> EffectInfo -> Q Type
instanceHead (Name -> Q Type
varT Name
eff) 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 )
taggerFunctions :: TaggedInfo -> Q [Dec]
taggerFunctions :: TaggedInfo -> Q [Dec]
taggerFunctions info :: TaggedInfo
info = do
let params :: [TyVarBndr]
params = TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
info
tagVar :: TyVarBndr
tagVar = TaggedInfo -> TyVarBndr
tgTag TaggedInfo
info
effectName :: Name
effectName = TaggedInfo -> Name
tgEffName TaggedInfo
info
nameString :: String
nameString = Name -> String
nameBase Name
effectName
tagFName :: Name
tagFName = String -> Name
mkName ("tag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
retagFName :: Name
retagFName = String -> Name
mkName ("retag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
untagFName :: Name
untagFName = String -> Name
mkName ("untag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
Name
tag <- String -> Q Name
newName (Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
tagVar)
Name
new <- String -> Q Name
newName "new"
[Dec]
tagF <- Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction Name
effectName Name
tagFName Maybe Name
forall a. Maybe a
Nothing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new) [TyVarBndr]
params
[Dec]
retagF <- Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction Name
effectName Name
retagFName (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
tag) (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new) [TyVarBndr]
params
[Dec]
untagF <- Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction Name
effectName Name
untagFName (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
tag) Maybe Name
forall a. Maybe a
Nothing [TyVarBndr]
params
[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 -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction :: Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction baseName :: Name
baseName funName :: Name
funName tag :: Maybe Name
tag new :: Maybe Name
new params :: [TyVarBndr]
params = do
Name
mName <- String -> Q Name
newName "m"
Name
aName <- String -> Q Name
newName "a"
let m :: Q Type
m = Name -> Q Type
varT Name
mName
a :: Q Type
a = Name -> Q Type
varT Name
aName
tagParam :: Q Type
tagParam = Q Type -> (Name -> Q Type) -> Maybe Name -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [t| G |] Name -> Q Type
varT Maybe Name
tag
newParam :: Q Type
newParam = Q Type -> (Name -> Q Type) -> Maybe Name -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [t| G |] Name -> Q Type
varT Maybe Name
new
tagNames :: [Name]
tagNames = Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
tag [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
new
paramNames :: [Name]
paramNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Name
tyVarName [TyVarBndr]
params
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
forallNames :: [Name]
forallNames = [Name]
tagNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
paramNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
mName, Name
aName]
forallTypes :: [TyVarBndr]
forallTypes = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr
PlainTV [Name]
forallNames
effectType :: Q Type
effectType = (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
baseName) (Q Type
tagParam Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes)
Type
funSigType <- [t| ($effectType `Via` Tagger $tagParam $newParam) $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] -> Q Cxt -> Q Type -> Q Type
forallT [TyVarBndr]
forallTypes ([Q Type] -> Q Cxt
cxt []) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
untaggedSynonym :: TaggedInfo -> Q Dec
untaggedSynonym :: TaggedInfo -> Q Dec
untaggedSynonym info :: TaggedInfo
info = do
Name
synName <- TaggedInfo -> Q Name
synonymName TaggedInfo
info
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
effectName) (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
effectName :: Name
effectName = TaggedInfo -> Name
tgEffName TaggedInfo
info
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
info)
untaggedFunctions :: TaggedInfo -> Q [Dec]
untaggedFunctions :: TaggedInfo -> Q [Dec]
untaggedFunctions info :: TaggedInfo
info = do
Name
synName <- TaggedInfo -> Q Name
synonymName TaggedInfo
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] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TaggedInfo -> [Signature]
tgSigs TaggedInfo
info)
((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (String -> Q String) -> Q Type -> Signature -> Q [Dec]
untaggedFunction (TaggedInfo -> String -> Q String
tgNameMap TaggedInfo
info)
(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
info [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TaggedInfo -> TyVarBndr
tgMonad TaggedInfo
info] )
untaggedFunction :: (String -> Q String) -> Q Type -> Signature -> Q [Dec]
untaggedFunction :: (String -> Q String) -> Q Type -> Signature -> Q [Dec]
untaggedFunction f :: String -> Q String
f effectType :: Q Type
effectType sig :: 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 <- (String -> Q String) -> Name -> Q Name
mapName String -> Q String
f Name
originalName
Dec
funSig <- Name -> Q Type -> Q Dec
sigD Name
funName [t| $effectType => $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 :: TaggedInfo -> Q Dec
taggerInstance :: TaggedInfo -> Q Dec
taggerInstance info :: TaggedInfo
info = do
Name
newTagName <- String -> Q Name
newName "new"
let new :: Q Type
new = Name -> Q Type
varT Name
newTagName
monadName :: Name
monadName = TyVarBndr -> Name
tyVarName (TaggedInfo -> TyVarBndr
tgMonad TaggedInfo
info)
m :: Q Type
m = Name -> Q Type
varT Name
monadName
tag :: Q Type
tag = TyVarBndr -> Q Type
tyVarType (TaggedInfo -> TyVarBndr
tgTag TaggedInfo
info)
effectType :: Q Type
effectType = Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TaggedInfo -> Name
tgEffName TaggedInfo
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 (TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
info)
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 (TaggedInfo -> [Signature]
tgSigs TaggedInfo
info) ((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
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceD
( [Q Type] -> Q Cxt
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
effectType [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
effectType [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 new :: Q Type
new monad :: Name
monad sig :: Signature
sig = do
let typ :: Type
typ = Signature -> Type
sigType Signature
sig
funName :: Name
funName = Signature -> Name
sigName Signature
sig
expr :: Q Exp
expr = Cxt -> 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)
paramCount :: Type -> Int
paramCount :: Type -> Int
paramCount typ :: Type
typ =
case Type
typ of
ArrowT `AppT` _ `AppT` r :: Type
r -> 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
paramCount Type
r
ForallT _ _ t :: Type
t -> Type -> Int
paramCount Type
t
_ -> 0
invalid :: Q Exp
invalid :: Q Exp
invalid = 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
$ "Could not generate effect instance because the operation is "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "invalid for higher-order effects."
handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions info :: 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 [| Via |] [| runVia |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
( EffectInfo -> [Signature]
effSigs EffectInfo
info )
lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions info :: EffectInfo
info =
let m :: TyVarBndr
m = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
params :: [TyVarBndr]
params = EffectInfo -> [TyVarBndr]
effParams EffectInfo
info
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]
effSigs EffectInfo
info) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \sig :: 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
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 f :: Q Exp
f inv :: Q Exp
inv monad :: TyVarBndr
monad params :: [TyVarBndr]
params sig :: 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 = Cxt -> 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 monad :: TyVarBndr
monad params :: [TyVarBndr]
params sig :: 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 :: Cxt
restores = Bool -> Name -> Type -> Cxt
restorables Bool
False Name
m Type
typ
expr :: Q Exp
expr = Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
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 "x")
Type
res <- 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 =
[| Via $
(liftWith $ \ $([p|run|]) -> $appliedExp)
>>= $(traverseExp res) (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]
unkindType :: Type -> Type
unkindType :: Type -> Type
unkindType typ :: Type
typ =
case Type
typ of
ForallT _ _ t :: Type
t -> Type -> Type
unkindType Type
t
AppT l :: Type
l r :: Type
r -> Type -> Type -> Type
AppT (Type -> Type
unkindType Type
l) (Type -> Type
unkindType Type
r)
SigT t :: Type
t _ -> Type
t
InfixT l :: Type
l n :: Name
n r :: Type
r -> Type -> Name -> Type -> Type
InfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
UInfixT l :: Type
l n :: Name
n r :: Type
r -> Type -> Name -> Type -> Type
UInfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
ParensT t :: Type
t -> Type -> Type
ParensT (Type -> Type
unkindType Type
t)
other :: Type
other -> Type
other
contains :: Name -> Type -> Bool
contains :: Name -> Type -> Bool
contains m :: Name
m typ :: Type
typ =
case Type
typ of
ForallT _ _ t :: Type
t -> Name -> Type -> Bool
contains Name
m Type
t
AppT l :: Type
l r :: Type
r -> Name -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
SigT t :: Type
t _ -> Name -> Type -> Bool
contains Name
m Type
t
VarT n :: Name
n -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
ConT n :: Name
n -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
PromotedT n :: Name
n -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
InfixT l :: Type
l n :: Name
n r :: 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 l :: Type
l n :: Name
n r :: 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 t :: Type
t -> Name -> Type -> Bool
contains Name
m Type
t
_ -> Bool
False
derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive :: Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive rs :: Cxt
rs f :: Q Exp
f inv :: Q Exp
inv m :: Name
m typ :: Type
typ =
case Type
typ of
t :: Type
t | Bool -> Bool
not (Name -> Type -> Bool
contains Name
m Type
t) ->
[| id |]
VarT n :: Name
n `AppT` _ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m ->
Q Exp
f
ArrowT `AppT` arg :: Type
arg `AppT` res :: Type
res ->
let rf :: Q Exp
rf = Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
rs Q Exp
f Q Exp
inv Name
m Type
res
af :: Q Exp
af = Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
rs Q Exp
inv Q Exp
f Name
m Type
arg
in if Type -> Cxt -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
arg Cxt
rs
then [| \x b -> $rf (((x =<<) . Via . restoreT . pure) b) |]
else [| \x b -> $rf (x ($af b)) |]
ForallT _ _ t :: Type
t ->
Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
rs Q Exp
f Q Exp
inv Name
m Type
t
other :: 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
$ "Could not generate effect instance because an unknown structure "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "was encountered: "
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 typ :: Type
typ =
case Type
typ of
ForallT _ _ t :: Type
t -> Type -> Q Exp
traverseExp Type
t
AppT _ r :: Type
r -> Type -> Q Exp
traverseRec Type
r
SigT t :: Type
t _ -> Type -> Q Exp
traverseExp Type
t
InfixT _ _ r :: Type
r -> Type -> Q Exp
traverseRec Type
r
UInfixT _ _ r :: Type
r -> Type -> Q Exp
traverseRec Type
r
ParensT t :: Type
t -> Type -> Q Exp
traverseExp Type
t
_ -> [| id |]
where
traverseRec :: Type -> Q Exp
traverseRec t :: Type
t = [| traverse . $(traverseExp t) |]