the Haskell binding now covers everything in the libsg API

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