{-# 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 ()
-----------------------------------------------------------------------