GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 01:22:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

update SG.hsc

Browse Source
This commit is contained in:
krasimir
2017-04-12 11:55:27 +00:00
parent 4e19b1d510
commit ee93c25d19
2 changed files with 63 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
src/runtime/haskell-bind/SG.hsc
View File

@@ -13,7 +13,7 @@ module SG( SG, openSG, closeSG
, readTriple, showTriple , readTriple, showTriple
, insertTriple, getTriple , insertTriple, getTriple
, queryTriple , queryTriple
, prepareQuery , query
) where ) where
import Foreign hiding (unsafePerformIO) import Foreign hiding (unsafePerformIO)
@@ -47,7 +47,7 @@ openSG fpath =
else do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError else do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError
if is_sgerr if is_sgerr
then do c_msg <- (#peek GuExn, data.data) exn then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekCString c_msg msg <- peekUtf8CString c_msg
throwIO (SGError msg) throwIO (SGError msg)
else throwIO (SGError "The database cannot be opened") else throwIO (SGError "The database cannot be opened")
else return (SG sg) else return (SG sg)
@@ -150,8 +150,8 @@ queryLinearization :: SG -> String -> IO [Expr]
queryLinearization (SG sg) query = do queryLinearization (SG sg) query = do
exprPl <- gu_new_pool exprPl <- gu_new_pool
exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl
(withCString query $ \c_query -> (withGuPool $ \tmpPl -> do
withGuPool $ \tmpPl -> do c_query <- newUtf8CString query tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
seq <- sg_query_linearization sg c_query tmpPl exn seq <- sg_query_linearization sg c_query tmpPl exn
handle_sg_exn exn handle_sg_exn exn
@@ -177,9 +177,9 @@ readTriple str =
unsafePerformIO $ unsafePerformIO $
do exprPl <- gu_new_pool do exprPl <- gu_new_pool
withGuPool $ \tmpPl -> withGuPool $ \tmpPl ->
withCString str $ \c_str ->
withTriple $ \triple -> withTriple $ \triple ->
do guin <- gu_string_in c_str tmpPl do c_str <- newUtf8CString str tmpPl
guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
ok <- pgf_read_expr_tuple guin 3 triple exprPl exn ok <- pgf_read_expr_tuple guin 3 triple exprPl exn
status <- gu_exn_is_raised exn status <- gu_exn_is_raised exn
@@ -188,7 +188,8 @@ readTriple str =
c_expr2 <- peekElemOff triple 1 c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2 c_expr3 <- peekElemOff triple 2
exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return $ Just (Expr c_expr1 exprFPl,Expr c_expr2 exprFPl,Expr c_expr3 exprFPl) let touch = touchForeignPtr exprFPl
return $ Just (Expr c_expr1 touch,Expr c_expr2 touch,Expr c_expr3 touch)
else do gu_pool_free exprPl else do gu_pool_free exprPl
return Nothing return Nothing
@@ -206,7 +207,7 @@ showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
pgf_print_expr_tuple 3 triple printCtxt out exn pgf_print_expr_tuple 3 triple printCtxt out exn
touch1 >> touch2 >> touch3 touch1 >> touch2 >> touch3
s <- gu_string_buf_freeze sb tmpPl s <- gu_string_buf_freeze sb tmpPl
peekCString s peekUtf8CString s
insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
@@ -288,34 +289,43 @@ queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 =
,fromCExpr c_expr2 touch mb_expr2 ,fromCExpr c_expr2 touch mb_expr2
,fromCExpr c_expr3 touch mb_expr3) : rest) ,fromCExpr c_expr3 touch mb_expr3) : rest)
data Query = forall a . Query {query :: Ptr SgQuery, queryMaster :: a}
prepareQuery :: SG -> String -> IO (Maybe Query) query :: SG -> String -> IO [[Expr]]
prepareQuery (SG sg) str = query (SG sg) str =
withGuPool $ \tmpPl -> withGuPool $ \tmpPl ->
withCString str $ \c_str -> do c_str <- newUtf8CString str tmpPl
do guin <- gu_string_in c_str tmpPl guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
queryPl <- gu_new_pool seq <- pgf_read_expr_matrix guin 3 tmpPl exn
q <- do seq <- pgf_read_expr_matrix guin 3 queryPl exn
if seq /= nullPtr if seq /= nullPtr
then do count <- (#peek GuSeq, len) seq then do count <- (#peek GuSeq, len) seq
sg_prepare_query sg (count `div` 3) (seq `plusPtr` (#offset GuSeq, data)) queryPl exn q <- sg_query sg (count `div` 3) (seq `plusPtr` (#offset GuSeq, data)) exn
else return nullPtr handle_sg_exn exn
n_cols <- sg_query_result_columns q
unsafeInterleaveIO (fetchResults q n_cols)
else return []
where
fetchResults q n_cols =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
pExprs <- gu_malloc tmpPl ((#size PgfExpr) * n_cols)
exprPl <- gu_new_pool
res <- sg_query_result_fetch q pExprs exprPl exn
failed <- gu_exn_is_raised exn failed <- gu_exn_is_raised exn
if failed if failed
then do gu_pool_free queryPl then do gu_pool_free exprPl
is_sgerr <- gu_exn_caught exn gu_exn_type_SgError sg_query_result_close q exn
if is_sgerr handle_sg_exn exn
then do c_msg <- (#peek GuExn, data.data) exn return []
msg <- peekCString c_msg else if res /= 0
throwIO (SGError msg) then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
else throwIO (SGError "Unknown database error") let touch = touchForeignPtr exprFPl
else if q == nullPtr row <- fmap (map (flip Expr touch)) $ peekArray (fromIntegral n_cols) pExprs
then do gu_pool_free queryPl rows <- unsafeInterleaveIO (fetchResults q n_cols)
return Nothing return (row:rows)
else do queryFPl <- newForeignPtr gu_pool_finalizer queryPl else do gu_pool_free exprPl
return (Just (Query q queryFPl)) sg_query_result_close q exn
return []
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- Exceptions -- Exceptions
@@ -331,7 +341,7 @@ handle_sg_exn exn = do
then do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError then do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError
if is_sgerr if is_sgerr
then do c_msg <- (#peek GuExn, data.data) exn then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekCString c_msg msg <- peekUtf8CString c_msg
throwIO (SGError msg) throwIO (SGError msg)
else throwIO (SGError "Unknown database error") else throwIO (SGError "Unknown database error")
else return () else return ()

13
src/runtime/haskell-bind/SG/FFI.hs
View File

@@ -10,7 +10,6 @@ import Data.Int
data SgSG data SgSG
data SgQueryExprResult data SgQueryExprResult
data SgTripleResult data SgTripleResult
data SgQuery
data SgQueryResult data SgQueryResult
type SgId = Int64 type SgId = Int64
@@ -65,13 +64,17 @@ foreign import ccall "sg/sg.h sg_triple_result_fetch"
foreign import ccall "sg/sg.h sg_triple_result_close" foreign import ccall "sg/sg.h sg_triple_result_close"
sg_triple_result_close :: Ptr SgTripleResult -> Ptr GuExn -> IO () sg_triple_result_close :: Ptr SgTripleResult -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_prepare_query"
sg_prepare_query :: Ptr SgSG -> CInt -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO (Ptr SgQuery)
foreign import ccall "sg/sg.h sg_query" foreign import ccall "sg/sg.h sg_query"
sg_query :: Ptr SgSG -> Ptr SgQuery -> Ptr GuExn -> IO (Ptr SgQueryResult) sg_query :: Ptr SgSG -> CInt -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult)
foreign import ccall "sg/sg.h sg_query_result_columns"
sg_query_result_columns :: Ptr SgQueryResult -> IO CInt
foreign import ccall "sg/sg.h sg_query_result_fetch"
sg_query_result_fetch :: Ptr SgQueryResult -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt
foreign import ccall "sg/sg.h sg_query_result_close"
sg_query_result_close :: Ptr SgQueryResult -> Ptr GuExn -> IO ()
type SgTriple = Ptr PgfExpr type SgTriple = Ptr PgfExpr