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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
{-# LANGUAGE ForeignFunctionInterface #-}
--
-- GF Python bindings
-- Jordi Saludes, upc.edu 2010, 2011
--
module PyGF where
import PGF
import Foreign
import CString
import Foreign.C.Types
import Control.Monad
import Data.Map (keys, (!))
import Data.Char (isSpace)
#include "pygf.h"
freeSp :: String -> Ptr a -> IO ()
freeSp tname p = do
--DEBUG putStrLn $ "about to free pointer " ++ tname ++ " at " ++ (show p)
sp <- (#peek PyGF, sp) p
--DEBUG putStrLn "peeked"
freeStablePtr sp
--DEBUG putStrLn $ "freeing " ++ tname ++ " at " ++ (show p)
instance Storable PGF where
sizeOf _ = (#size PyGF)
alignment _ = alignment (undefined::CInt)
poke p o = do
sp <- newStablePtr o
(#poke PyGF, sp) p sp
peek p = do
sp <- (#peek PyGF, sp) p
deRefStablePtr sp
instance Storable Type where
sizeOf _ = (#size PyGF)
alignment _ = alignment (undefined::CInt)
poke p o = do
sp <- newStablePtr o
(#poke PyGF, sp) p sp
peek p = do
sp <- (#peek PyGF, sp) p
deRefStablePtr sp
instance Storable Language where
sizeOf _ = (#size PyGF)
alignment _ = alignment (undefined::CInt)
poke p o = do
sp <- newStablePtr o
(#poke PyGF, sp) p sp
peek p = do
sp <- (#peek PyGF, sp) p
deRefStablePtr sp
instance Storable Tree where
sizeOf _ = (#size PyGF)
alignment _ = alignment (undefined::CInt)
poke p o = do
sp <- newStablePtr o
(#poke PyGF, sp) p sp
peek p = do
sp <- (#peek PyGF, sp) p
deRefStablePtr sp
-- It is CId the same as Tree?
{- instance Storable CId where
sizeOf _ = (#size PyGF)
alignment _ = alignment (undefined::CInt)
poke p o = do
sp <- newStablePtr o
(#poke PyGF, sp) p sp
peek p = do
sp <- (#peek PyGF, sp) p
deRefStablePtr sp
-}
foreign export ccall gf_freePGF :: Ptr PGF -> IO ()
foreign export ccall gf_freeType :: Ptr Type -> IO ()
foreign export ccall gf_freeLanguage :: Ptr Language -> IO ()
foreign export ccall gf_freeTree :: Ptr Tree -> IO ()
foreign export ccall gf_freeExpr :: Ptr Expr -> IO ()
foreign export ccall gf_freeCId :: Ptr CId -> IO ()
gf_freePGF = freeSp "pgf"
gf_freeType = freeSp "type"
gf_freeLanguage = freeSp "language"
gf_freeTree = freeSp "tree"
gf_freeExpr = freeSp "expression"
gf_freeCId = freeSp "CId"
{-foreign export ccall gf_printCId :: Ptr CId-> IO CString
gf_printCId p = do
c <- peek p
newCString (showCId c)
-}
foreign export ccall gf_readPGF :: CString -> IO (Ptr PGF)
gf_readPGF path = do
ppgf <- pyPGF
p <- peekCString path
readPGF p >>= poke ppgf
return ppgf
foreign export ccall gf_readLanguage :: Ptr Language -> CString -> IO Bool
gf_readLanguage pt str = do
s <- (peekCString str)
case (readLanguage s) of
Just x -> do
poke pt x
return True
Nothing -> return False
foreign export ccall gf_startCat :: Ptr PGF -> IO (Ptr Type)
gf_startCat ppgf = do
pgf <- peek ppgf
pcat <- pyType
poke pcat (startCat pgf)
return pcat
foreign export ccall gf_parse :: Ptr PGF -> Ptr Language -> Ptr Type -> CString -> IO (Ptr ())
gf_parse ppgf plang pcat input = do
p <- peek ppgf
c <- peek pcat
i <- peekCString input
l <- peek plang
let parsed = parse p l c i
--DEBUG putStrLn $ (show $ length parsed) ++ " parsings"
listToPy pyTree parsed
foreign export ccall gf_showExpr :: Ptr Expr -> IO CString
gf_showExpr pexpr = do
e <- peek pexpr
newCString (showExpr [] e)
listToPy :: Storable a => IO (Ptr a) -> [a] -> IO (Ptr ()) -- opaque -- IO (Ptr (Ptr Language))
listToPy mk ls = do
pyls <- pyList
mapM_ (mpoke pyls) ls
return pyls
where mpoke pyl l = do
pl <- mk
poke pl l
pyl << pl
listToPyStrings :: [String] -> IO (Ptr ())
listToPyStrings ss = do
pyls <- pyList
mapM_ (mpoke pyls) ss
return pyls
where mpoke pyl s = do
cs <- newCString s
pcs <- pyString cs
pyl << pcs
foreign export ccall gf_showLanguage :: Ptr Language -> IO CString
gf_showLanguage plang = do
l <- peek plang
newCString $ showLanguage l
foreign export ccall gf_showType :: Ptr Type -> IO CString
gf_showType ptp = do
t <- peek ptp
newCString $ showType [] t
foreign export ccall gf_showPrintName :: Ptr PGF -> Ptr Language -> Ptr CId -> IO CString
gf_showPrintName ppgf plang pcid = do
pgf <- peek ppgf
lang <- peek plang
cid <- peek pcid
newCString (showPrintName pgf lang cid)
foreign export ccall gf_abstractName :: Ptr PGF -> IO (Ptr Language)
gf_abstractName ppgf = do
pabs <- pyLang
pgf <- peek ppgf
poke pabs $ abstractName pgf
return pabs
foreign export ccall gf_linearize :: Ptr PGF -> Ptr Language -> Ptr Tree -> IO CString
gf_linearize ppgf plang ptree = do
pgf <- peek ppgf
lang <- peek plang
tree <- peek ptree
newCString $ linearize pgf lang tree
foreign export ccall gf_languageCode :: Ptr PGF -> Ptr Language -> IO CString
gf_languageCode ppgf plang = do
pgf <- peek ppgf
lang <- peek plang
case languageCode pgf lang of
Just s -> newCString s
Nothing -> return nullPtr
foreign export ccall gf_languages :: Ptr PGF -> IO (Ptr ()) -- (Ptr (Ptr Language))
gf_languages ppgf = do
pgf <- peek ppgf
listToPy pyLang $ languages pgf
foreign export ccall gf_categories :: Ptr PGF -> IO (Ptr ())
gf_categories ppgf = do
pgf <- peek ppgf
listToPy pyCId $ categories pgf
foreign export ccall gf_showCId :: Ptr CId -> IO CString
gf_showCId pcid = do
cid <- peek pcid
newCString $ showCId cid
foreign export ccall gf_unapp :: Ptr Expr -> IO (Ptr ())
foreign export ccall gf_unint :: Ptr Expr -> IO CInt
foreign export ccall gf_unstr :: Ptr Expr -> IO CString
gf_unapp pexp = do
exp <- peek pexp
case unApp exp of
Just (f,args) -> do
puexp <- pyList
pf <- pyCId
poke pf f
puexp << pf
mapM_ (\e -> do
pe <- pyExpr
poke pe e
puexp << pe) args
return puexp
Nothing -> return nullPtr
gf_unint pexp = do
exp <- peek pexp
return $ fromIntegral $ case unInt exp of
Just n -> n
_ -> (-9)
gf_unstr pexp = do
exp <- peek pexp
case unStr exp of
Just s -> newCString s
_ -> return nullPtr
foreign export ccall gf_inferexpr :: Ptr PGF -> Ptr Expr -> IO (Ptr Type)
gf_inferexpr ppgf pexp = do
pgf <- peek ppgf
exp <- peek pexp
case inferExpr pgf exp of
Right (_,t) -> do
ptype <- pyType
poke ptype t
return ptype
Left _ -> return nullPtr
foreign export ccall gf_functions :: Ptr PGF -> IO (Ptr ())
gf_functions ppgf = do
pgf <- peek ppgf
listToPy pyCId $ functions pgf
foreign export ccall gf_functiontype :: Ptr PGF -> Ptr CId -> IO (Ptr Type)
gf_functiontype ppgf pcid = do
pgf <- peek ppgf
cid <- peek pcid
case functionType pgf cid of
Just t -> do
ptp <- pyType
poke ptp t
return ptp
_ -> return nullPtr
foreign export ccall gf_completions :: Ptr PGF -> Ptr Language -> Ptr Type -> CString -> IO (Ptr ())
gf_completions ppgf plang pcat ctoks = do
pgf <- peek ppgf
lang <- peek plang
cat <- peek pcat
toks <- peekCString ctoks
let (rpre,rs) = break isSpace (reverse toks)
pre = reverse rpre
ws = words (reverse rs)
state0 = initState pgf lang cat
completions =
case loop state0 ws of
Nothing -> []
Just state -> keys $ getCompletions state pre
listToPyStrings completions
where
loop ps [] = Just ps
loop ps (w:ws) =
case nextState ps (simpleParseInput w) of
Left _ -> Nothing
Right ps -> loop ps ws
foreign import ccall "newLang" pyLang :: IO (Ptr Language)
foreign import ccall "newPGF" pyPGF :: IO (Ptr PGF)
foreign import ccall "newTree" pyTree :: IO (Ptr Tree)
foreign import ccall "newgfType" pyType :: IO (Ptr Type)
foreign import ccall "newCId" pyCId :: IO (Ptr CId)
foreign import ccall "newExpr" pyExpr :: IO (Ptr Expr)
foreign import ccall "newList" pyList :: IO (Ptr ())
foreign import ccall "newString" pyString :: CString -> IO (Ptr ())
foreign import ccall "append" (<<) :: Ptr () -> Ptr a -> IO ()
|
