mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-13 06:49:31 -06:00
349 lines
12 KiB
Haskell
349 lines
12 KiB
Haskell
{-# 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 $
|
|
withTriple $ \triple -> do
|
|
tmpPl <- gu_new_pool
|
|
(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
|
|
peekUtf8CStringBufResult sb tmpPl
|
|
|
|
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 ()
|
|
|
|
-----------------------------------------------------------------------
|