summaryrefslogtreecommitdiff
path: root/src/runtime/haskell-bind
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell-bind')
-rw-r--r--src/runtime/haskell-bind/PGF2/FFI.hsc6
-rw-r--r--src/runtime/haskell-bind/SG.hsc349
-rw-r--r--src/runtime/haskell-bind/SG/FFI.hs84
-rw-r--r--src/runtime/haskell-bind/pgf2.cabal6
4 files changed, 3 insertions, 442 deletions
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index b348f5012..082b58d36 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -531,12 +531,6 @@ foreign import ccall "pgf/pgf.h pgf_print"
foreign import ccall "pgf/expr.h pgf_read_expr"
pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
-foreign import ccall "pgf/expr.h pgf_read_expr_tuple"
- pgf_read_expr_tuple :: Ptr GuIn -> CSizeT -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt
-
-foreign import ccall "pgf/expr.h pgf_read_expr_matrix"
- pgf_read_expr_matrix :: Ptr GuIn -> CSizeT -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
-
foreign import ccall "pgf/expr.h pgf_read_type"
pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType
diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc
deleted file mode 100644
index 791abc767..000000000
--- a/src/runtime/haskell-bind/SG.hsc
+++ /dev/null
@@ -1,349 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}
-
-#include <pgf/pgf.h>
-#include <gu/exn.h>
-#include <sg/sg.h>
-
-module SG( SG, openSG, closeSG
- , beginTrans, commit, rollback, inTransaction
- , SgId
- , insertExpr, getExpr, queryExpr
- , updateFtsIndex
- , queryLinearization
- , readTriple, showTriple
- , insertTriple, getTriple
- , queryTriple
- , query
- ) 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 <- peekUtf8CString 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 touch) =
- withGuPool $ \tmpPl -> do
- exn <- gu_new_exn tmpPl
- id <- sg_insert_expr sg expr 1 exn
- touch
- 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 (touchForeignPtr exprFPl))
-
-queryExpr :: SG -> Expr -> IO [(SgId,Expr)]
-queryExpr (SG sg) (Expr query touch) =
- withGuPool $ \tmpPl -> do
- exn <- gu_new_exn tmpPl
- res <- sg_query_expr sg query tmpPl exn
- touch
- handle_sg_exn exn
- fetchResults res exn
- where
- fetchResults res exn = do
- exprPl <- gu_new_pool
- (key,c_expr) <- alloca $ \pKey -> do
- c_expr <- sg_query_next sg res pKey exprPl exn
- key <- peek pKey
- return (key,c_expr)
- failed <- gu_exn_is_raised exn
- if failed
- then do gu_pool_free exprPl
- sg_query_close sg res exn
- handle_sg_exn exn
- return []
- else if c_expr == nullPtr
- then do gu_pool_free exprPl
- sg_query_close sg res exn
- return []
- else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
- rest <- fetchResults res exn
- return ((key,Expr c_expr (touchForeignPtr exprFPl)) : rest)
-
-updateFtsIndex :: SG -> PGF -> IO ()
-updateFtsIndex (SG sg) p = do
- withGuPool $ \tmpPl -> do
- exn <- gu_new_exn tmpPl
- sg_update_fts_index sg (pgf p) exn
- handle_sg_exn exn
-
-queryLinearization :: SG -> String -> IO [Expr]
-queryLinearization (SG sg) query = do
- exprPl <- gu_new_pool
- exprFPl <- newForeignPtr gu_pool_finalizer exprPl
- (withGuPool $ \tmpPl -> do
- c_query <- newUtf8CString query tmpPl
- exn <- gu_new_exn tmpPl
- seq <- sg_query_linearization sg c_query tmpPl exn
- handle_sg_exn exn
- len <- (#peek GuSeq, len) seq
- ids <- peekArray (fromIntegral (len :: CInt)) (seq `plusPtr` (#offset GuSeq, data))
- getExprs exprFPl exprPl exn ids)
- where
- getExprs exprFPl exprPl exn [] = return []
- getExprs exprFPl exprPl exn (id:ids) = do
- c_expr <- sg_get_expr sg id exprPl exn
- handle_sg_exn exn
- if c_expr == nullPtr
- then getExprs exprFPl exprPl exn ids
- else do let e = Expr c_expr (touchForeignPtr exprFPl)
- es <- getExprs exprFPl exprPl exn ids
- return (e:es)
-
------------------------------------------------------------------------
--- Triples
-
-readTriple :: String -> Maybe (Expr,Expr,Expr)
-readTriple str =
- unsafePerformIO $
- do exprPl <- gu_new_pool
- withGuPool $ \tmpPl ->
- withTriple $ \triple ->
- do c_str <- newUtf8CString str tmpPl
- 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
- let touch = touchForeignPtr exprFPl
- return $ Just (Expr c_expr1 touch,Expr c_expr2 touch,Expr c_expr3 touch)
- else do gu_pool_free exprPl
- return Nothing
-
-showTriple :: Expr -> Expr -> Expr -> String
-showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
- unsafePerformIO $
- withGuPool $ \tmpPl ->
- withTriple $ \triple -> do
- (sb,out) <- newOut tmpPl
- let printCtxt = nullPtr
- exn <- gu_new_exn tmpPl
- pokeElemOff triple 0 expr1
- pokeElemOff triple 1 expr2
- pokeElemOff triple 2 expr3
- pgf_print_expr_tuple 3 triple printCtxt out exn
- touch1 >> touch2 >> touch3
- s <- gu_string_buf_freeze sb tmpPl
- peekUtf8CString s
-
-insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
-insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
- 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
- touch1 >> touch2 >> touch3
- 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
- let touch = touchForeignPtr exprFPl
- 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 touch
- ,Expr c_expr2 touch
- ,Expr c_expr3 touch
- ))
- else do touch
- 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 touch Nothing = Expr c_expr touch
- fromCExpr c_expr touch (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
- let touch = touchForeignPtr exprFPl
- 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 touch mb_expr1
- ,fromCExpr c_expr2 touch mb_expr2
- ,fromCExpr c_expr3 touch mb_expr3) : rest)
-
-
-query :: SG -> String -> IO [[Expr]]
-query (SG sg) str =
- withGuPool $ \tmpPl ->
- do c_str <- newUtf8CString str tmpPl
- guin <- gu_string_in c_str tmpPl
- exn <- gu_new_exn tmpPl
- seq <- pgf_read_expr_matrix guin 3 tmpPl exn
- if seq /= nullPtr
- then do count <- (#peek GuSeq, len) seq
- q <- sg_query sg (count `div` 3) (seq `plusPtr` (#offset GuSeq, data)) exn
- 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
- if failed
- then do gu_pool_free exprPl
- sg_query_result_close q exn
- 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
-
-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 <- peekUtf8CString c_msg
- throwIO (SGError msg)
- else throwIO (SGError "Unknown database error")
- else return ()
-
------------------------------------------------------------------------
diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell-bind/SG/FFI.hs
deleted file mode 100644
index ef1b06de8..000000000
--- a/src/runtime/haskell-bind/SG/FFI.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
-module SG.FFI where
-
-import Foreign
-import Foreign.C
-import PGF2.FFI
-import GHC.Ptr
-import Data.Int
-
-data SgSG
-data SgQueryExprResult
-data SgTripleResult
-data SgQueryResult
-type SgId = Int64
-
-foreign import ccall "sg/sg.h sg_open"
- sg_open :: CString -> Ptr GuExn -> IO (Ptr SgSG)
-
-foreign import ccall "sg/sg.h sg_close"
- sg_close :: Ptr SgSG -> Ptr GuExn -> IO ()
-
-foreign import ccall "sg/sg.h sg_begin_trans"
- sg_begin_trans :: Ptr SgSG -> Ptr GuExn -> IO ()
-
-foreign import ccall "sg/sg.h sg_commit"
- sg_commit :: Ptr SgSG -> Ptr GuExn -> IO ()
-
-foreign import ccall "sg/sg.h sg_rollback"
- sg_rollback :: Ptr SgSG -> Ptr GuExn -> IO ()
-
-foreign import ccall "sg/sg.h sg_insert_expr"
- sg_insert_expr :: Ptr SgSG -> PgfExpr -> CInt -> 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_query_expr"
- sg_query_expr :: Ptr SgSG -> PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO (Ptr SgQueryExprResult)
-
-foreign import ccall "sg/sg.h sg_query_next"
- sg_query_next :: Ptr SgSG -> Ptr SgQueryExprResult -> Ptr SgId -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
-
-foreign import ccall "sg/sg.h sg_query_close"
- sg_query_close :: Ptr SgSG -> Ptr SgQueryExprResult -> Ptr GuExn -> IO ()
-
-foreign import ccall "sg/sg.h sg_update_fts_index"
- sg_update_fts_index :: Ptr SgSG -> Ptr PgfPGF -> Ptr GuExn -> IO ()
-
-foreign import ccall "sg/sg.h sg_query_linearization"
- sg_query_linearization :: Ptr SgSG -> CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
-
-foreign import ccall "sg/sg.h sg_insert_triple"
- sg_insert_triple :: Ptr SgSG -> SgTriple -> Ptr GuExn -> IO 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 ()
-
-foreign import ccall "sg/sg.h sg_query"
- sg_query :: Ptr SgSG -> CSizeT -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult)
-
-foreign import ccall "sg/sg.h sg_query_result_columns"
- sg_query_result_columns :: Ptr SgQueryResult -> IO CSizeT
-
-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
-
-withTriple :: (SgTriple -> IO a) -> IO a
-withTriple = allocaArray 3
-
-gu_exn_type_SgError = Ptr "SgError"# :: CString
diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index 4022f0b9b..9197bff9a 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -14,17 +14,17 @@ extra-source-files: README
cabal-version: >=1.10
library
- exposed-modules: PGF2, PGF2.Internal, SG
+ exposed-modules: PGF2, PGF2.Internal
-- backwards compatibility API:
--, PGF, PGF.Internal
- other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
+ other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type
build-depends: base >=4.3,
containers, pretty
-- hs-source-dirs:
default-language: Haskell2010
build-tools: hsc2hs
- extra-libraries: sg pgf gu
+ extra-libraries: pgf gu
cc-options: -std=c99
c-sources: utils.c
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:24:21 +0000