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
|
{-# LANGUAGE DeriveDataTypeable #-}
#include <pgf/pgf.h>
#include <gu/exn.h>
#include <sg/sg.h>
module SG( SG, openSG, closeSG
, beginTrans, commit, rollback, inTransaction
, SgId
, insertExpr, getExpr
, readTriple, insertTriple, getTriple
, queryTriple
) where
import Foreign hiding (unsafePerformIO)
import Foreign.C
import SG.FFI
import PGF2.FFI
import PGF2.Expr
import Data.Typeable
import Control.Exception(Exception,SomeException,catch,throwIO)
import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
-----------------------------------------------------------------------
-- Global database operations and types
newtype SG = SG {sg :: Ptr SgSG}
openSG :: FilePath -> IO SG
openSG fpath =
withCString fpath $ \c_fpath ->
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_open c_fpath exn
failed <- gu_exn_is_raised exn
if failed
then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno
if is_errno
then do perrno <- (#peek GuExn, data.data) exn
errno <- peek perrno
ioError (errnoToIOError "openSG" (Errno errno) Nothing (Just fpath))
else do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError
if is_sgerr
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekCString c_msg
throwIO (SGError msg)
else throwIO (SGError "The database cannot be opened")
else return (SG sg)
closeSG :: SG -> IO ()
closeSG (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_close sg exn
handle_sg_exn exn
beginTrans :: SG -> IO ()
beginTrans (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_begin_trans sg exn
handle_sg_exn exn
commit :: SG -> IO ()
commit (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_commit sg exn
handle_sg_exn exn
rollback :: SG -> IO ()
rollback (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_rollback sg exn
handle_sg_exn exn
inTransaction :: SG -> IO a -> IO a
inTransaction sg f =
catch (beginTrans sg >> f >>= \x -> commit sg >> return x)
(\e -> rollback sg >> throwIO (e :: SomeException))
-----------------------------------------------------------------------
-- Expressions
insertExpr :: SG -> Expr -> IO SgId
insertExpr (SG sg) (Expr expr _) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
id <- sg_insert_expr sg expr exn
handle_sg_exn exn
return id
getExpr :: SG -> SgId -> IO (Maybe Expr)
getExpr (SG sg) id = do
exprPl <- gu_new_pool
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
c_expr <- sg_get_expr sg id exprPl exn
handle_sg_exn exn
if c_expr == nullPtr
then do touchForeignPtr exprFPl
return Nothing
else do return $ Just (Expr c_expr exprFPl)
-----------------------------------------------------------------------
-- Triples
readTriple :: String -> Maybe (Expr,Expr,Expr)
readTriple str =
unsafePerformIO $
do exprPl <- gu_new_pool
withGuPool $ \tmpPl ->
withCString str $ \c_str ->
withTriple $ \triple -> do
do guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl
ok <- pgf_read_expr_tuple guin 3 triple exprPl exn
status <- gu_exn_is_raised exn
if (ok == 1 && not status)
then do c_expr1 <- peekElemOff triple 0
c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return $ Just (Expr c_expr1 exprFPl,Expr c_expr2 exprFPl,Expr c_expr3 exprFPl)
else do gu_pool_free exprPl
return Nothing
insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) =
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
pokeElemOff triple 0 expr1
pokeElemOff triple 1 expr2
pokeElemOff triple 2 expr3
id <- sg_insert_triple sg triple exn
handle_sg_exn exn
return id
getTriple :: SG -> SgId -> IO (Maybe (Expr,Expr,Expr))
getTriple (SG sg) id = do
exprPl <- gu_new_pool
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
res <- sg_get_triple sg id triple exprPl exn
handle_sg_exn exn
if res /= 0
then do c_expr1 <- peekElemOff triple 0
c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2
return (Just (Expr c_expr1 exprFPl
,Expr c_expr2 exprFPl
,Expr c_expr3 exprFPl
))
else do touchForeignPtr exprFPl
return Nothing
queryTriple :: SG -> Maybe Expr -> Maybe Expr -> Maybe Expr -> IO [(SgId,Expr,Expr,Expr)]
queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 =
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
pokeElemOff triple 0 (toCExpr mb_expr1)
pokeElemOff triple 1 (toCExpr mb_expr2)
pokeElemOff triple 2 (toCExpr mb_expr3)
res <- sg_query_triple sg triple exn
handle_sg_exn exn
unsafeInterleaveIO (fetchResults res)
where
toCExpr Nothing = nullPtr
toCExpr (Just (Expr expr _)) = expr
fromCExpr c_expr exprFPl Nothing = Expr c_expr exprFPl
fromCExpr c_expr exprFPl (Just e) = e
fetchResults res = do
exprPl <- gu_new_pool
alloca $ \pKey ->
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
r <- sg_triple_result_fetch res pKey triple exprPl exn
failed <- gu_exn_is_raised exn
if failed
then do gu_pool_free exprPl
sg_triple_result_close res exn
handle_sg_exn exn
return []
else if r == 0
then do gu_pool_free exprPl
sg_triple_result_close res exn
return []
else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
c_expr1 <- peekElemOff triple 0
c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2
key <- peek pKey
rest <- unsafeInterleaveIO (fetchResults res)
return ((key,fromCExpr c_expr1 exprFPl mb_expr1
,fromCExpr c_expr2 exprFPl mb_expr2
,fromCExpr c_expr3 exprFPl mb_expr3) : rest)
-----------------------------------------------------------------------
-- Exceptions
newtype SGError = SGError String
deriving (Show, Typeable)
instance Exception SGError
handle_sg_exn exn = do
failed <- gu_exn_is_raised exn
if failed
then do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError
if is_sgerr
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekCString c_msg
throwIO (SGError msg)
else throwIO (SGError "Unknown database error")
else return ()
-----------------------------------------------------------------------
|
