blob: 27c87b1a0a208a811570a0e426b21a29126e4cec (
plain)
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
|
{-# LANGUAGE ForeignFunctionInterface #-}
module PyGF where
import PGF
import Foreign
import CString
import Foreign.C.Types
import Control.Monad
#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 :: Ptr PGF -> CString -> IO ()
gf_readPGF pt path = do
p <- (peekCString path)
result <- (readPGF p)
poke pt result
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 -> Ptr Type -> IO ()
gf_startCat ppgf pcat= do
pgf <- peek ppgf
poke pcat (startCat pgf)
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
let bufl = length ls + 1
-- buf <- mallocBytes $ (#size PyGF) * bufl
pyls <- pyList
-- pokeElemOff buf (length ls) nullPtr
mapM_ (mpoke pyls) ls
return pyls
where mpoke pyl l = do
pl <- mk
poke pl l
pyl << pl
-- foreign export ccall "gf_freeArray" free :: Ptr a -> IO ()
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 -> Ptr Language -> IO ()
gf_abstractName ppgf pabs = do
pgf <- peek ppgf
poke pabs $ abstractName pgf
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 import ccall "newLang" pyLang :: IO (Ptr Language)
foreign import ccall "newTree" pyTree :: IO (Ptr Tree)
foreign import ccall "newCId" pyCId :: IO (Ptr CId)
foreign import ccall "newList" pyList :: IO (Ptr ())
foreign import ccall "append" (<<) :: Ptr () -> Ptr a -> IO ()
|
