{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Effectful.TH
( makeEffect
, makeEffect_
) where
import Control.Monad
import Data.Char (toLower)
import Data.Foldable (foldl')
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import qualified Data.Map.Strict as Map
import Effectful
import Effectful.Dispatch.Dynamic
makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect = Bool -> Name -> Q [Dec]
makeEffectImpl Bool
True
makeEffect_ :: Name -> Q [Dec]
makeEffect_ :: Name -> Q [Dec]
makeEffect_ = Bool -> Name -> Q [Dec]
makeEffectImpl Bool
False
makeEffectImpl :: Bool -> Name -> Q [Dec]
makeEffectImpl :: Bool -> Name -> Q [Dec]
makeEffectImpl Bool
makeSig Name
effName = do
Q ()
checkRequiredExtensions
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
effName
Dec
dispatch <- do
Type
e <- Type -> [Type] -> Q Type
getEff (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Name
datatypeName DatatypeInfo
info) (DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
info)
let dispatchE :: Type
dispatchE = Name -> Type
ConT ''DispatchOf Type -> Type -> Type
`AppT` Type
e
dynamic :: Type
dynamic = Name -> Type
PromotedT 'Dynamic
Dec -> Q Dec
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> (TySynEqn -> Dec) -> TySynEqn -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TySynEqn -> Dec
TySynInstD (TySynEqn -> Q Dec) -> TySynEqn -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
dispatchE Type
dynamic
[[Dec]]
ops <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Name -> Q [Dec]
makeCon Bool
makeSig) (ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)
[Dec] -> Q [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
dispatch Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [[Dec]] -> [Dec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [[Dec]]
forall a. [a] -> [a]
reverse [[Dec]]
ops)
where
getEff :: Type -> [Type] -> Q Type
getEff :: Type -> [Type] -> Q Type
getEff Type
e = \case
[Type
m, Type
r] -> do
[Char] -> Type -> Type -> Q ()
forall (f :: Type -> Type).
MonadFail f =>
[Char] -> Type -> Type -> f ()
checkKind [Char]
"the next to last" (Type
ArrowT Type -> Type -> Type
`AppT` Type
StarT Type -> Type -> Type
`AppT` Type
StarT) Type
m
[Char] -> Type -> Type -> Q ()
forall (f :: Type -> Type).
MonadFail f =>
[Char] -> Type -> Type -> f ()
checkKind [Char]
"the last" Type
StarT Type
r
Type -> Q Type
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
e
(Type
v : [Type]
vs) -> Type -> [Type] -> Q Type
getEff (Type
e Type -> Type -> Type
`AppT` Type -> Type
forgetKind Type
v) [Type]
vs
[Type]
_ -> [Char] -> Q Type
forall (m :: Type -> Type) a. MonadFail m => [Char] -> m a
fail [Char]
"The effect data type needs at least 2 type parameters"
where
forgetKind :: Type -> Type
forgetKind = \case
SigT Type
v Type
_ -> Type
v
Type
ty -> Type
ty
checkKind :: [Char] -> Type -> Type -> f ()
checkKind [Char]
which Type
expected = \case
SigT (VarT Name
_) Type
k
| Type
k Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
expected -> () -> f ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
| Bool
otherwise -> [Char] -> f ()
forall (m :: Type -> Type) a. MonadFail m => [Char] -> m a
fail
([Char] -> f ()) -> [Char] -> f ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
which [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" type parameter to have a kind "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
expected [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
k
Type
_ -> () -> f ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
makeCon :: Bool -> Name -> Q [Dec]
makeCon :: Bool -> Name -> Q [Dec]
makeCon Bool
makeSig Name
name = do
Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
name
Type
typ <- Name -> Q Info
reify Name
name Q Info -> (Info -> Q Type) -> Q Type
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
DataConI Name
_ Type
typ Name
_ -> Type -> Q Type
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
typ
Info
_ -> [Char] -> Q Type
forall (m :: Type -> Type) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Type) -> [Char] -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char]
"Not a data constructor: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
name
([Type]
actionParams, (Type
effTy, Either Name Name
ename, Type
resTy)) <- Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
typ
(Name
esName, Maybe Name
maybeMonadName) <- case Either Name Name
ename of
Left Name
esName -> (Name, Maybe Name) -> Q (Name, Maybe Name)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Name
esName, Maybe Name
forall a. Maybe a
Nothing)
Right Name
monadName -> (, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
monadName) (Name -> (Name, Maybe Name)) -> Q Name -> Q (Name, Maybe Name)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q Name
newName [Char]
"es"
let fnName :: Name
fnName = [Char] -> Name
mkName ([Char] -> Name) -> ([Char] -> [Char]) -> [Char] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
toSmartConName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
name
[Name]
fnArgs <- (Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ [Char] -> Q Name
newName [Char]
"x") [Type]
actionParams
let esVar :: Type
esVar = Name -> Type
VarT Name
esName
substM :: Type -> Type
substM :: Type -> Type
substM = case Maybe Name
maybeMonadName of
Just Name
m -> Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (Map Name Type -> Type -> Type)
-> (Type -> Map Name Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
m (Type -> Type -> Type) -> Type -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar
Maybe Name
Nothing -> Type -> Type
forall a. a -> a
id
([TyVarBndr]
origActionVars, [Type]
actionCtx) = Type -> ([TyVarBndr], [Type])
extractCtx Type
typ
actionVars :: [TyVarBndr]
actionVars = case Maybe Name
maybeMonadName of
Just Name
m -> (TyVarBndr -> Bool) -> [TyVarBndr] -> [TyVarBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name
m Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Name -> Bool) -> (TyVarBndr -> Name) -> TyVarBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
forall flag. TyVarBndr -> Name
tvName) [TyVarBndr]
origActionVars
[TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> Type -> TyVarBndr
kindedTVSpecified Name
esName (Type -> TyVarBndr) -> Type -> TyVarBndr
forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` Name -> Type
ConT ''Effect]
Maybe Name
Nothing -> [TyVarBndr]
origActionVars
#if MIN_VERSION_template_haskell(2,17,0)
let fnBody =
let tvFlag = \case
PlainTV _ flag -> flag
KindedTV _ flag _ -> flag
tyApps = (`mapMaybe` origActionVars) $ \v -> case tvFlag v of
InferredSpec -> Nothing
SpecifiedSpec -> Just $ if maybeMonadName == Just (tvName v)
then ConT ''Eff `AppT` esVar
else VarT (tvName v)
effCon = if makeSig
then foldl' AppTypeE (ConE name) tyApps
else ConE name
in VarE 'send `AppE` foldl' (\f -> AppE f . VarE) effCon fnArgs
#else
let fnBody :: Exp
fnBody =
let effOp :: Exp
effOp = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
f -> Exp -> Exp -> Exp
AppE Exp
f (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) (Name -> Exp
ConE Name
name) [Name]
fnArgs
effSig :: Type
effSig = Type
effTy Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar) Type -> Type -> Type
`AppT` Type -> Type
substM Type
resTy
in if Bool
makeSig
then Name -> Exp
VarE 'send Exp -> Exp -> Exp
`AppE` Exp -> Type -> Exp
SigE Exp
effOp Type
effSig
else Name -> Exp
VarE 'send Exp -> Exp -> Exp
`AppE` Exp
effOp
#endif
let fnSig :: Type
fnSig = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
actionVars
(Name -> Type
ConT ''HasCallStack Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> Name -> Type -> Type
UInfixT Type
effTy ''(:>) Type
esVar Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
actionCtx)
(Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp Type
esVar Type -> Type
substM Type
resTy [Type]
actionParams)
let rest :: [Dec]
rest = Name -> [Clause] -> Dec
FunD Name
fnName [[Pat] -> Body -> [Dec] -> Clause
Clause (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fnArgs) (Exp -> Body
NormalB Exp
fnBody) []]
Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Maybe Dec -> [Dec]
forall a. Maybe a -> [a]
maybeToList ((Fixity -> Name -> Dec
`InfixD` Name
name) (Fixity -> Dec) -> Maybe Fixity -> Maybe Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Fixity
fixity)
([Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
rest) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Dec] -> Q [Dec]
withHaddock Name
name [Name -> Type -> Dec
SigD Name
fnName Type
fnSig | Bool
makeSig]
toSmartConName :: String -> String
toSmartConName :: [Char] -> [Char]
toSmartConName = \case
(Char
':' : [Char]
xs) -> [Char]
xs
(Char
x : [Char]
xs) -> Char -> Char
toLower Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs
[Char]
_ -> [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"empty constructor name"
extractCtx :: Type -> ([TyVarBndrSpec], Cxt)
= \case
ForallT [TyVarBndr]
vars [Type]
ctx Type
_ -> ([TyVarBndr]
vars, [Type]
ctx)
Type
ty -> [Char] -> ([TyVarBndr], [Type])
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([TyVarBndr], [Type]))
-> [Char] -> ([TyVarBndr], [Type])
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty
extractParams :: Type -> Q ([Type], (Type, Either Name Name, Type))
= \case
ForallT [TyVarBndr]
_ [Type]
_ Type
ty -> Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
SigT Type
ty Type
_ -> Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
ParensT Type
ty -> Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
Type
ArrowT `AppT` Type
a `AppT` Type
ty -> do
([Type]
args, (Type, Either Name Name, Type)
ret) <- Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args, (Type, Either Name Name, Type)
ret)
#if MIN_VERSION_template_haskell(2,17,0)
MulArrowT `AppT` _ `AppT` a `AppT` ty -> do
(args, ret) <- extractParams ty
pure (a : args, ret)
#endif
Type
effTy `AppT` Type
monadTy `AppT` Type
resTy -> case Type
monadTy of
VarT Name
monadName -> ([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name -> Either Name Name
forall a b. b -> Either a b
Right Name
monadName, Type
resTy))
ConT Name
eff `AppT` VarT Name
esName
| Name
eff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eff -> ([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name -> Either Name Name
forall a b. a -> Either a b
Left Name
esName, Type
resTy))
Type
ty -> [Char] -> Q ([Type], (Type, Either Name Name, Type))
forall (m :: Type -> Type) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q ([Type], (Type, Either Name Name, Type)))
-> [Char] -> Q ([Type], (Type, Either Name Name, Type))
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid instantiation of the monad parameter: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
ty
Type
ty -> [Char] -> Q ([Type], (Type, Either Name Name, Type))
forall (m :: Type -> Type) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q ([Type], (Type, Either Name Name, Type)))
-> [Char] -> Q ([Type], (Type, Either Name Name, Type))
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
ty
makeTyp :: Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp :: Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp Type
esVar Type -> Type
substM Type
resTy = \case
[] -> Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar Type -> Type -> Type
`AppT` Type -> Type
substM Type
resTy
(Type
p : [Type]
ps) -> Type
ArrowT Type -> Type -> Type
`AppT` Type -> Type
substM Type
p Type -> Type -> Type
`AppT` Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp Type
esVar Type -> Type
substM Type
resTy [Type]
ps
withHaddock :: Name -> [Dec] -> Q [Dec]
#if MIN_VERSION_template_haskell(2,18,0)
withHaddock name dec = withDecsDoc
("Perform the operation '" ++ nameBase name ++ "'.") (pure dec)
#else
withHaddock :: Name -> [Dec] -> Q [Dec]
withHaddock Name
_ [Dec]
dec = [Dec] -> Q [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Dec]
dec
#endif
checkRequiredExtensions :: Q ()
checkRequiredExtensions :: Q ()
checkRequiredExtensions = do
[Extension]
missing <- (Extension -> Q Bool) -> [Extension] -> Q [Extension]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool) -> (Extension -> Q Bool) -> Extension -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> Q Bool
isExtEnabled) [Extension]
exts
let ppMissing :: [[Char]]
ppMissing = (Extension -> [Char]) -> [Extension] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\Extension
ext -> [Char]
"{-# LANGUAGE " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Extension -> [Char]
forall a. Show a => a -> [Char]
show Extension
ext [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" #-}") [Extension]
missing
Bool -> Q () -> Q ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([Extension] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Extension]
missing) (Q () -> Q ()) -> ([[Char]] -> Q ()) -> [[Char]] -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q ()
forall (m :: Type -> Type) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q ()) -> ([[Char]] -> [Char]) -> [[Char]] -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> Q ()) -> [[Char]] -> Q ()
forall a b. (a -> b) -> a -> b
$
[ [Char]
"Generating functions requires additional language extensions.\n"
, [Char]
"You can enable them by adding them to the 'default-extensions'"
, [Char]
"field in the .cabal file or the following pragmas to the beginning"
, [Char]
"of the source file:\n"
] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
ppMissing
where
exts :: [Extension]
exts = [ Extension
FlexibleContexts
, Extension
ScopedTypeVariables
#if MIN_VERSION_template_haskell(2,17,0)
, TypeApplications
#endif
, Extension
TypeFamilies
, Extension
TypeOperators
]