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

drop the SG library completely.

Browse Source
This commit is contained in:
krangelov
2020-07-08 21:12:01 +02:00
parent 47d1da0845
commit 33818076ff
17 changed files with 11 additions and 52880 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/runtime/haskell-bind/PGF2/FFI.hsc
View File

@@ -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

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

@@ -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 ()
-----------------------------------------------------------------------

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

@@ -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

6
src/runtime/haskell-bind/pgf2.cabal
View File

@@ -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