{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Emacs.Module.Raw.Env.TH (wrapEmacsFunc, Safety(..)) where
import Control.Monad.IO.Class
import Data.List (foldl')
import Foreign.Ptr as Foreign
import Language.Haskell.TH
import Data.Emacs.Module.Raw.Env.Internal as Env
decomposeFunctionType :: Type -> ([Type], Type)
decomposeFunctionType :: Type -> ([Type], Type)
decomposeFunctionType = [Type] -> Type -> ([Type], Type)
go []
where
go :: [Type] -> Type -> ([Type], Type)
go :: [Type] -> Type -> ([Type], Type)
go [Type]
args = \case
ForallT [TyVarBndr]
_ [Type]
_ Type
t -> [Type] -> Type -> ([Type], Type)
go [Type]
args Type
t
AppT (AppT Type
ArrowT Type
x) Type
y -> [Type] -> Type -> ([Type], Type)
go (Type
x Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args) Type
y
Type
ret -> ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args, Type
ret)
#if MIN_VERSION_template_haskell(2, 17, 0)
unwrapForall :: Type -> (Maybe ([TyVarBndr Specificity], Cxt), Type)
#else
unwrapForall :: Type -> (Maybe ([TyVarBndr], Cxt), Type)
#endif
unwrapForall :: Type -> (Maybe ([TyVarBndr], [Type]), Type)
unwrapForall (ForallT [TyVarBndr]
bs [Type]
c Type
t) = (([TyVarBndr], [Type]) -> Maybe ([TyVarBndr], [Type])
forall a. a -> Maybe a
Just ([TyVarBndr]
bs, [Type]
c), Type
t)
unwrapForall Type
t = (Maybe ([TyVarBndr], [Type])
forall a. Maybe a
Nothing, Type
t)
#if MIN_VERSION_template_haskell(2, 17, 0)
wrapForall :: Maybe ([TyVarBndr Specificity], Cxt) -> Type -> Type
#else
wrapForall :: Maybe ([TyVarBndr], Cxt) -> Type -> Type
#endif
wrapForall :: Maybe ([TyVarBndr], [Type]) -> Type -> Type
wrapForall Maybe ([TyVarBndr], [Type])
Nothing = Type -> Type
forall a. a -> a
id
wrapForall (Just ([TyVarBndr]
bs, [Type]
c)) = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
bs [Type]
c
wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ
wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ
wrapEmacsFunc String
name Safety
safety ExpQ
peekExpr TypeQ
rawFuncType = do
Type
rawFuncType' <- TypeQ
rawFuncType
let (Maybe ([TyVarBndr], [Type])
forallCxt, Type
rawFuncType'') = Type -> (Maybe ([TyVarBndr], [Type]), Type)
unwrapForall Type
rawFuncType'
([Type]
args, Type
_ret) = Type -> ([Type], Type)
decomposeFunctionType Type
rawFuncType''
(Name
envArg, [Name]
otherArgs) <- case [Type]
args of
[] -> String -> Q (Name, [Name])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Name])) -> String -> Q (Name, [Name])
forall a b. (a -> b) -> a -> b
$
String
"Raw function type must take at least one emacs_env argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
rawFuncType'
Type
x : [Type]
xs
| Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
ConT ''Env.Env -> String -> Q (Name, [Name])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Name])) -> String -> Q (Name, [Name])
forall a b. (a -> b) -> a -> b
$
String
"Raw function type must take emacs_env as a first argument, but takes " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
rawFuncType'
| Bool
otherwise ->
(,) (Name -> [Name] -> (Name, [Name]))
-> Q Name -> Q ([Name] -> (Name, [Name]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"env" Q ([Name] -> (Name, [Name])) -> Q [Name] -> Q (Name, [Name])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) 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 (String -> Q Name
newName String
"x")) [Type]
xs
Name
foreignFuncName <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"emacs_func_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
let envPat :: PatQ
envPat = Name -> PatQ
varP Name
envArg
pats :: [PatQ]
pats = PatQ
envPat PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
otherArgs
body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ do
Name
funPtrVar <- String -> Q Name
newName String
"funPtr"
[e|liftIO|] ExpQ -> ExpQ -> ExpQ
`appE` [StmtQ] -> ExpQ
doE
[ PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
funPtrVar) (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ ExpQ
peekExpr ExpQ -> ExpQ -> ExpQ
`appE` ([e| Env.toPtr |] ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
envArg)
, ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
foreignFuncName) ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE ([Name] -> [ExpQ]) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> a -> b
$ Name
funPtrVar Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Name
envArg Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
otherArgs)
]
Dec
mainDecl <- Name -> [ClauseQ] -> DecQ
funD Name
name' [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
pats BodyQ
body []]
Dec
inlinePragma <- Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD Name
name' Inline
Inline RuleMatch
FunLike Phases
AllPhases
let foreignDeclType :: TypeQ
foreignDeclType =
(Type -> Type) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ([TyVarBndr], [Type]) -> Type -> Type
wrapForall Maybe ([TyVarBndr], [Type])
forallCxt) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$
TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` (Name -> TypeQ
conT ''Foreign.FunPtr TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rawFuncType'') TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rawFuncType''
Dec
foreignDecl <- Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
forImpD Callconv
cCall Safety
safety String
"dynamic" Name
foreignFuncName TypeQ
foreignDeclType
[Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
mainDecl, Dec
inlinePragma, Dec
foreignDecl]
where
name' :: Name
name' = String -> Name
mkName String
name