-
Notifications
You must be signed in to change notification settings - Fork 13
/
TH.hs
111 lines (104 loc) · 3.37 KB
/
TH.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
{-# LANGUAGE TemplateHaskell #-}
module FFICXX.Runtime.Function.TH where
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
--
import FFICXX.Runtime.CodeGen.Cxx (CMacro (..), CStatement (..), renderCMacro, renderCStmt)
import FFICXX.Runtime.Function.Template (Function)
import FFICXX.Runtime.TH
( FunctionParamInfo (..),
con,
mkDelete,
mkInstance,
mkMember,
mkNew,
mkTFunc,
)
import FFICXX.Runtime.Types (FFISafety (..))
import Foreign.Ptr (FunPtr)
import Language.Haskell.TH (forImpD, safe)
import Language.Haskell.TH.Syntax
( Body (NormalB),
Callconv (CCall),
Clause (..),
Dec (..),
Exp (..),
ForeignSrcLang (LangCxx),
Q,
Type (..),
addForeignSource,
addModFinalizer,
addTopDecls,
mkNameS,
newName,
)
mkWrapper :: (Type, String) -> Q Dec
mkWrapper (typ, suffix) =
do
let fn = "wrap_" <> suffix
n <- newName fn
d <- forImpD CCall safe "wrapper" n [t|$(pure typ) -> IO (FunPtr ($(pure typ)))|]
addTopDecls [d]
pure $
FunD (mkNameS "wrapFunPtr") [Clause [] (NormalB (VarE n)) []]
t_newFunction :: Type -> String -> Q Exp
t_newFunction typ suffix =
mkTFunc FFIUnsafe (typ, suffix, \n -> "Function_new_" <> n, tyf)
where
tyf _n =
let t = pure typ
in [t|FunPtr $(t) -> IO (Function $(t))|]
t_call :: FFISafety -> Type -> String -> Q Exp
t_call safety typ suffix =
mkTFunc safety (typ, suffix, \n -> "Function_call_" <> n, tyf)
where
tyf _n =
let t = pure typ
in [t|Function $(t) -> $(t)|]
t_deleteFunction :: Type -> String -> Q Exp
t_deleteFunction typ suffix =
mkTFunc FFIUnsafe (typ, suffix, \n -> "Function_delete_" <> n, tyf)
where
tyf _n =
let t = pure typ
in [t|Function $(t) -> IO ()|]
genFunctionInstanceFor :: Q Type -> FunctionParamInfo -> Q [Dec]
genFunctionInstanceFor qtyp param =
do
let suffix = fpinfoSuffix param
typ <- qtyp
f1 <- mkNew "newFunction" t_newFunction typ suffix
-- NOTE: The indirected function call should be safe.
f2 <- mkMember "call" (t_call FFISafe) typ suffix
f3 <- mkDelete "deleteFunction" t_deleteFunction typ suffix
wrap <- mkWrapper (typ, suffix)
addModFinalizer
( addForeignSource
LangCxx
( "\n#include \"functional\"\n\n\n#include \"Function.h\"\n\n"
++ ( let headers = fpinfoCxxHeaders param
f x = renderCMacro (Include x)
in concatMap f headers
)
++ ( let nss = fpinfoCxxNamespaces param
f x = renderCStmt (UsingNamespace x)
in concatMap f nss
)
++ ( let retstr = fromMaybe "void" (fpinfoCxxRetType param)
argstr =
let args = fpinfoCxxArgTypes param
vs = case args of
[] -> "(,)"
_ ->
intercalate "," $
map (\(t, x) -> "(" ++ t ++ "," ++ x ++ ")") args
in "(" ++ vs ++ ")"
in "Function(" ++ suffix ++ "," ++ retstr ++ "," ++ argstr ++ ")\n"
)
)
)
let lst = [f1, f2, f3]
return
[ mkInstance [] (AppT (con "IFunction") typ) lst,
mkInstance [] (AppT (con "FunPtrWrapper") typ) [wrap]
]