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

100
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,20 +177,21 @@ 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 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
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
if (ok == 1 && not status) if (ok == 1 && not status)
then do c_expr1 <- peekElemOff triple 0 then do c_expr1 <- peekElemOff triple 0
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
else do gu_pool_free exprPl return $ Just (Expr c_expr1 touch,Expr c_expr2 touch,Expr c_expr3 touch)
return Nothing else do gu_pool_free exprPl
return Nothing
showTriple :: Expr -> Expr -> Expr -> String showTriple :: Expr -> Expr -> Expr -> String
showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
@@ -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 q <- sg_query sg (count `div` 3) (seq `plusPtr` (#offset GuSeq, data)) exn
sg_prepare_query sg (count `div` 3) (seq `plusPtr` (#offset GuSeq, data)) queryPl exn handle_sg_exn exn
else return nullPtr n_cols <- sg_query_result_columns q
failed <- gu_exn_is_raised exn unsafeInterleaveIO (fetchResults q n_cols)
if failed else return []
then do gu_pool_free queryPl where
is_sgerr <- gu_exn_caught exn gu_exn_type_SgError fetchResults q n_cols =
if is_sgerr withGuPool $ \tmpPl -> do
then do c_msg <- (#peek GuExn, data.data) exn exn <- gu_new_exn tmpPl
msg <- peekCString c_msg pExprs <- gu_malloc tmpPl ((#size PgfExpr) * n_cols)
throwIO (SGError msg) exprPl <- gu_new_pool
else throwIO (SGError "Unknown database error") res <- sg_query_result_fetch q pExprs exprPl exn
else if q == nullPtr failed <- gu_exn_is_raised exn
then do gu_pool_free queryPl if failed
return Nothing then do gu_pool_free exprPl
else do queryFPl <- newForeignPtr gu_pool_finalizer queryPl sg_query_result_close q exn
return (Just (Query q queryFPl)) handle_sg_exn exn
return []
else if res /= 0
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
let touch = touchForeignPtr exprFPl
row <- fmap (map (flip Expr touch)) $ peekArray (fromIntegral n_cols) pExprs
rows <- unsafeInterleaveIO (fetchResults q n_cols)
return (row:rows)
else do gu_pool_free exprPl
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