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
|
-- GF C Bindings
-- Copyright (C) 2008-2009 Kevin Kofler
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, see <http://www.gnu.org/licenses/>.
module PGFFFI where
import PGF
import CString
import Foreign
import Foreign.C.Types
import Control.Exception
import IO
import Data.Maybe
import GF.Text.Lexing
-- Utility functions used in the implementation (not exported):
-- This is a kind of a hack, the FFI spec doesn't guarantee that this will work.
-- The alternative would be to use Ptr () instead of StablePtr a everywhere.
nullStablePtr :: StablePtr a
nullStablePtr = (castPtrToStablePtr nullPtr)
sizeOfStablePtr :: Int
sizeOfStablePtr = (sizeOf (nullStablePtr))
storeList :: [a] -> Ptr (StablePtr a) -> IO ()
storeList list buf = do
case list of
carlist:cdrlist -> do
sptr <- (newStablePtr carlist)
(poke buf sptr)
(storeList cdrlist (plusPtr buf sizeOfStablePtr))
[] -> (poke buf nullStablePtr)
listToArray :: [a] -> IO (Ptr (StablePtr a))
listToArray list = do
buf <- (mallocBytes ((sizeOfStablePtr) * ((length list) + 1)))
(storeList list buf)
return buf
-- PGF:
foreign export ccall "gf_freePGF" freeStablePtr :: StablePtr PGF -> IO ()
foreign export ccall gf_readPGF :: CString -> IO (StablePtr PGF)
gf_readPGF path = do
p <- (peekCString path)
result <- (readPGF p)
(newStablePtr result)
foreign export ccall "gf_freeLanguage" freeStablePtr :: StablePtr Language -> IO ()
foreign export ccall gf_showLanguage :: StablePtr Language -> IO CString
gf_showLanguage lang = do
l <- (deRefStablePtr lang)
(newCString (showLanguage l))
foreign export ccall gf_readLanguage :: CString -> IO (StablePtr Language)
gf_readLanguage str = do
s <- (peekCString str)
case (readLanguage s) of
Just x -> (newStablePtr x)
Nothing -> (return (nullStablePtr))
foreign export ccall gf_languages :: StablePtr PGF -> IO (Ptr (StablePtr Language))
gf_languages pgf = do
p <- (deRefStablePtr pgf)
(listToArray (languages p))
foreign export ccall gf_abstractName :: StablePtr PGF -> IO (StablePtr Language)
gf_abstractName pgf = do
p <- (deRefStablePtr pgf)
(newStablePtr (abstractName p))
foreign export ccall gf_languageCode :: StablePtr PGF -> StablePtr Language -> IO CString
gf_languageCode pgf lang = do
p <- (deRefStablePtr pgf)
l <- (deRefStablePtr lang)
case (languageCode p l) of
Just s -> (newCString s)
Nothing -> (return nullPtr)
foreign export ccall "gf_freeType" freeStablePtr :: StablePtr Type -> IO ()
foreign export ccall gf_showType :: StablePtr Type -> IO CString
gf_showType tp = do
t <- (deRefStablePtr tp)
(newCString (showType t))
foreign export ccall gf_readType :: CString -> IO (StablePtr Type)
gf_readType str = do
s <- (peekCString str)
case (readType s) of
Just x -> (newStablePtr x)
Nothing -> (return (nullStablePtr))
foreign export ccall gf_categories :: StablePtr PGF -> IO (Ptr (StablePtr Type))
gf_categories pgf = do
p <- (deRefStablePtr pgf)
(listToArray (categories p))
foreign export ccall gf_startCat :: StablePtr PGF -> IO (StablePtr Type)
gf_startCat pgf = do
p <- (deRefStablePtr pgf)
(newStablePtr (startCat p))
foreign export ccall "gf_freeCId" freeStablePtr :: StablePtr CId -> IO ()
foreign export ccall gf_mkCId :: CString -> IO (StablePtr CId)
gf_mkCId str = do
s <- (peekCString str)
(newStablePtr (mkCId s))
foreign export ccall gf_prCId :: StablePtr CId -> IO CString
gf_prCId cid = do
c <- (deRefStablePtr cid)
(newCString (prCId c))
foreign export ccall gf_wildCId :: IO (StablePtr CId)
gf_wildCId = do
(newStablePtr (wildCId))
-- TODO: So we can create, print and free a CId, but can we do anything useful with it?
-- We need some kind of C wrapper for the tree datastructures.
foreign export ccall "gf_freeTree" freeStablePtr :: StablePtr Tree -> IO ()
-- TODO: Literal(..)
-- (Not much use exporting a free function for that type if you can't do anything with it.)
foreign export ccall gf_showTree :: StablePtr Tree -> IO CString
gf_showTree tree = do
t <- (deRefStablePtr tree)
(newCString (showTree t))
foreign export ccall gf_readTree :: CString -> IO (StablePtr Tree)
gf_readTree str = do
s <- (peekCString str)
case (readTree s) of
Just x -> (newStablePtr x)
Nothing -> (return (nullStablePtr))
foreign export ccall "gf_freeExpr" freeStablePtr :: StablePtr Expr -> IO ()
-- TODO: Equation(..)
-- (Not much use exporting a free function for that type if you can't do anything with it.)
foreign export ccall gf_showExpr :: StablePtr Expr -> IO CString
gf_showExpr expr = do
e <- (deRefStablePtr expr)
(newCString (showExpr e))
foreign export ccall gf_readExpr :: CString -> IO (StablePtr Expr)
gf_readExpr str = do
s <- (peekCString str)
case (readExpr s) of
Just x -> (newStablePtr x)
Nothing -> (return (nullStablePtr))
foreign export ccall gf_linearize :: StablePtr PGF -> StablePtr Language -> StablePtr Tree -> IO CString
gf_linearize pgf lang tree = do
p <- (deRefStablePtr pgf)
l <- (deRefStablePtr lang)
t <- (deRefStablePtr tree)
(newCString (linearize p l t))
-- TODO: linearizeAllLang, linearizeAll
foreign export ccall gf_showPrintName :: StablePtr PGF -> StablePtr Language -> StablePtr Type -> IO CString
gf_showPrintName pgf lang tp = do
p <- (deRefStablePtr pgf)
l <- (deRefStablePtr lang)
t <- (deRefStablePtr tp)
(newCString (showPrintName p l t))
foreign export ccall gf_parse :: StablePtr PGF -> StablePtr Language -> StablePtr Type -> CString -> IO (Ptr (StablePtr Tree))
gf_parse pgf lang cat input = do
p <- (deRefStablePtr pgf)
l <- (deRefStablePtr lang)
c <- (deRefStablePtr cat)
i <- (peekCString input)
(listToArray (parse p l c i))
foreign export ccall gf_canParse :: StablePtr PGF -> StablePtr Language -> IO CInt
gf_canParse pgf lang = do
p <- (deRefStablePtr pgf)
l <- (deRefStablePtr lang)
case (canParse p l) of
True -> (return 1)
False -> (return 0)
-- TODO: parseAllLang, parseAll
-- TODO: tree2expr, expr2tree, PGF.compute, paraphrase, typecheck
-- TODO: complete, Incremental.ParseState, initState, Incremental.nextState, Incremental.getCompletions, extractExps
-- TODO: generateRandom, generateAll, generateAllDepth
-- GF.Text.Lexing:
foreign export ccall gf_stringOp :: CString -> CString -> IO CString
gf_stringOp op str = do
o <- (peekCString op)
s <- (peekCString str)
case (stringOp o) of
Just fn -> (newCString (fn s))
Nothing -> (return nullPtr)
-- Unused (exception handling):
-- (Control.Exception.catch (listToArray (parse p l c i)) (\(e::SomeException) -> do
-- (hPutStr stderr ("error: " ++ show e))
-- (return nullPtr)))
|
