From 0b392e8cff9ecac3ea12e99dc4c4b8e11377f82b Mon Sep 17 00:00:00 2001 From: krasimir Date: Fri, 4 Sep 2015 10:02:42 +0000 Subject: [PATCH] the Haskell binding now covers everything in the libsg API --- src/runtime/haskell-bind/SG.hsc | 96 ++++++++++++++++++++++++++---- src/runtime/haskell-bind/SG/FFI.hs | 19 +++++- 2 files changed, 103 insertions(+), 12 deletions(-) diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc index 300cec27a..a2fdf5505 100644 --- a/src/runtime/haskell-bind/SG.hsc +++ b/src/runtime/haskell-bind/SG.hsc @@ -7,8 +7,9 @@ module SG( SG, openSG, closeSG , beginTrans, commit, rollback, inTransaction , SgId - , insertExpr - , insertTriple + , insertExpr, getExpr + , insertTriple, getTriple + , queryTriple ) where import Foreign @@ -19,6 +20,7 @@ import PGF2.Expr import Data.Typeable import Control.Exception(Exception,SomeException,catch,throwIO) +import System.IO.Unsafe(unsafeInterleaveIO) ----------------------------------------------------------------------- -- Global database operations and types @@ -90,6 +92,19 @@ insertExpr (SG sg) (Expr expr _) = 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 @@ -98,19 +113,78 @@ insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) = withGuPool $ \tmpPl -> withTriple $ \triple -> do exn <- gu_new_exn tmpPl - id1 <- sg_insert_expr sg expr1 exn - handle_sg_exn exn - pokeElemOff triple 0 id1 - id2 <- sg_insert_expr sg expr2 exn - handle_sg_exn exn - pokeElemOff triple 1 id2 - id3 <- sg_insert_expr sg expr3 exn - handle_sg_exn exn - pokeElemOff triple 2 id3 + 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 diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell-bind/SG/FFI.hs index 2874082bb..37c7f8c3a 100644 --- a/src/runtime/haskell-bind/SG/FFI.hs +++ b/src/runtime/haskell-bind/SG/FFI.hs @@ -8,6 +8,7 @@ import GHC.Ptr import Data.Int data SgSG +data SgTripleResult type SgId = Int64 foreign import ccall "sg/sg.h sg_open" @@ -28,10 +29,26 @@ foreign import ccall "sg/sg.h sg_rollback" foreign import ccall "sg/sg.h sg_insert_expr" sg_insert_expr :: Ptr SgSG -> PgfExpr -> Ptr GuExn -> IO SgId +foreign import ccall "sg/sg.h sg_get_expr" + sg_get_expr :: Ptr SgSG -> SgId -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr + foreign import ccall "sg/sg.h sg_insert_triple" sg_insert_triple :: Ptr SgSG -> SgTriple -> Ptr GuExn -> IO SgId -type SgTriple = Ptr SgId +foreign import ccall "sg/sg.h sg_get_triple" + sg_get_triple :: Ptr SgSG -> SgId -> SgTriple -> Ptr GuPool -> Ptr GuExn -> IO CInt + +foreign import ccall "sg/sg.h sg_query_triple" + sg_query_triple :: Ptr SgSG -> SgTriple -> Ptr GuExn -> IO (Ptr SgTripleResult) + +foreign import ccall "sg/sg.h sg_triple_result_fetch" + sg_triple_result_fetch :: Ptr SgTripleResult -> Ptr SgId -> SgTriple -> Ptr GuPool -> Ptr GuExn -> IO CInt + +foreign import ccall "sg/sg.h sg_triple_result_close" + sg_triple_result_close :: Ptr SgTripleResult -> Ptr GuExn -> IO () + + +type SgTriple = Ptr PgfExpr withTriple :: (SgTriple -> IO a) -> IO a withTriple = allocaArray 3