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

safer memory management in the Haskell binding

Browse Source
This commit is contained in:
krasimir
2017-02-10 17:10:37 +00:00
parent a8cd866be0
commit 72fc90d13e
5 changed files with 94 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
src/runtime/haskell-bind/PGF2.hsc
View File

@@ -124,8 +124,8 @@ readPGF fpath =
else do gu_pool_free pool
throwIO (PGFError "The grammar cannot be loaded")
else return pgf
master <- newForeignPtr gu_pool_finalizer pool
return PGF {pgf = pgf, pgfMaster = master}
pgfFPtr <- newForeignPtr gu_pool_finalizer pool
return (PGF pgf (touchForeignPtr pgfFPtr))
-- | List of all languages available in the grammar.
languages :: PGF -> Map.Map ConcName Concr
@@ -143,7 +143,7 @@ languages p =
getLanguages ref itor key value exn = do
langs <- readIORef ref
name <- peekUtf8CString (castPtr key)
concr <- fmap (\ptr -> Concr ptr p) $ peek (castPtr value)
concr <- fmap (\ptr -> Concr ptr (touchPGF p)) $ peek (castPtr value)
writeIORef ref $! Map.insert name concr langs
-- | Generates an exhaustive possibly infinite list of
@@ -158,7 +158,7 @@ generateAll p (Type ctype _) =
enum <- pgf_generate_all (pgf p) ctype exn genPl exprPl
genFPl <- newForeignPtr gu_pool_finalizer genPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
fromPgfExprEnum enum genFPl (p,exprFPl)
fromPgfExprEnum enum genFPl (touchPGF p >> touchForeignPtr exprFPl)
-- | The abstract language name is the name of the top-level
-- abstract module
@@ -174,7 +174,8 @@ startCat :: PGF -> Type
startCat p = unsafePerformIO $ do
typPl <- gu_new_pool
c_type <- pgf_start_cat (pgf p) typPl
return (Type c_type typPl)
typeFPl <- newForeignPtr gu_pool_finalizer typPl
return (Type c_type (touchForeignPtr typeFPl))
loadConcr :: Concr -> FilePath -> IO ()
loadConcr c fpath =
@@ -207,11 +208,11 @@ functionType p fn =
c_type <- pgf_function_type (pgf p) c_fn
if c_type == nullPtr
then throwIO (PGFError ("Function '"++fn++"' is not defined"))
else return (Type c_type (pgfMaster p))
else return (Type c_type (touchPGF p))
-- | Checks an expression against a specified type.
checkExpr :: PGF -> Expr -> Type -> Either String Expr
checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) =
checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) =
unsafePerformIO $
alloca $ \pexpr ->
withGuPool $ \tmpPl -> do
@@ -219,11 +220,12 @@ checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) =
exprPl <- gu_new_pool
poke pexpr c_expr
pgf_check_expr p pexpr c_ty exn exprPl
touch1 >> touch2
status <- gu_exn_is_raised exn
if not status
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
c_expr <- peek pexpr
return (Right (Expr c_expr exprFPl))
return (Right (Expr c_expr (touchForeignPtr exprFPl)))
else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError
c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
@@ -237,7 +239,7 @@ checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) =
-- possible to infer its type in the GF type system.
-- In this case the function returns an error.
inferExpr :: PGF -> Expr -> Either String (Expr, Type)
inferExpr (PGF p _) (Expr c_expr _) =
inferExpr (PGF p _) (Expr c_expr touch1) =
unsafePerformIO $
alloca $ \pexpr ->
withGuPool $ \tmpPl -> do
@@ -245,11 +247,13 @@ inferExpr (PGF p _) (Expr c_expr _) =
exprPl <- gu_new_pool
poke pexpr c_expr
c_ty <- pgf_infer_expr p pexpr exn exprPl
touch1
status <- gu_exn_is_raised exn
if not status
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
let touch = touchForeignPtr exprFPl
c_expr <- peek pexpr
return (Right (Expr c_expr exprFPl, Type c_ty exprFPl))
return (Right (Expr c_expr touch, Type c_ty touch))
else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError
c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
@@ -261,7 +265,7 @@ inferExpr (PGF p _) (Expr c_expr _) =
-- | Check whether a type is consistent with the abstract
-- syntax of the grammar.
checkType :: PGF -> Type -> Either String Type
checkType (PGF p _) (Type c_ty _) =
checkType (PGF p _) (Type c_ty touch1) =
unsafePerformIO $
alloca $ \pty ->
withGuPool $ \tmpPl -> do
@@ -269,11 +273,12 @@ checkType (PGF p _) (Type c_ty _) =
typePl <- gu_new_pool
poke pty c_ty
pgf_check_type p pty exn typePl
touch1
status <- gu_exn_is_raised exn
if not status
then do typeFPl <- newForeignPtr gu_pool_finalizer typePl
c_ty <- peek pty
return (Right (Type c_ty typeFPl))
return (Right (Type c_ty (touchForeignPtr typeFPl)))
else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError
c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
@@ -283,16 +288,17 @@ checkType (PGF p _) (Type c_ty _) =
else throwIO (PGFError msg)
compute :: PGF -> Expr -> Expr
compute (PGF p _) (Expr c_expr _) =
compute (PGF p _) (Expr c_expr touch1) =
unsafePerformIO $
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
exprPl <- gu_new_pool
c_expr <- pgf_compute p c_expr exn tmpPl exprPl
touch1
status <- gu_exn_is_raised exn
if not status
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr exprFPl)
return (Expr c_expr (touchForeignPtr exprFPl))
else do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
gu_pool_free exprPl
@@ -309,6 +315,7 @@ graphvizAbstractTree p e =
do (sb,out) <- newOut tmpPl
exn <- gu_new_exn tmpPl
pgf_graphviz_abstract_tree (pgf p) (expr e) out exn
touchExpr e
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
@@ -320,6 +327,7 @@ graphvizParseTree c e =
do (sb,out) <- newOut tmpPl
exn <- gu_new_exn tmpPl
pgf_graphviz_parse_tree (concr c) (expr e) out exn
touchExpr e
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
@@ -358,6 +366,7 @@ fullFormLexicon lang =
peek ptr
if ffEntry == nullPtr
then do finalizeForeignPtr fpl
touchConcr lang
return []
else do tok <- peekUtf8CString =<< pgf_fullform_get_string ffEntry
ref <- newIORef []
@@ -423,7 +432,7 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks =
throwIO (PGFError "Parsing failed")
else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
exprs <- fromPgfExprEnum enum parseFPl (lang,exprFPl)
exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl)
return (Right exprs)
mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
@@ -509,7 +518,7 @@ parseWithOracle lang cat sent (predict,complete,literal) =
throwIO (PGFError "Parsing failed")
else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
exprs <- fromPgfExprEnum enum parseFPl (lang,exprFPl)
exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl)
return (Right exprs)
where
oracleWrapper oracle catPtr lblPtr offset = do
@@ -556,6 +565,7 @@ linearize lang e = unsafePerformIO $
do (sb,out) <- newOut pl
exn <- gu_new_exn pl
pgf_linearize (concr lang) (expr e) out exn
touchExpr e
failed <- gu_exn_is_raised exn
if failed
then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
@@ -586,6 +596,7 @@ linearizeAll lang e = unsafePerformIO $
peek ptr
if ctree == nullPtr
then do gu_pool_free pl
touchExpr e
return []
else do (sb,out) <- newOut tmpPl
ctree <- pgf_lzr_wrap_linref ctree tmpPl
@@ -598,7 +609,7 @@ linearizeAll lang e = unsafePerformIO $
else throwExn exn pl
else do lin <- gu_string_buf_freeze sb tmpPl
s <- peekUtf8CString lin
ss <- unsafeInterleaveIO (collect cts exn pl)
ss <- collect cts exn pl
return (s:ss)
throwExn exn pl = do
@@ -653,6 +664,7 @@ alignWords lang e = unsafePerformIO $
withGuPool $ \pl ->
do exn <- gu_new_exn pl
seq <- pgf_align_words (concr lang) (expr e) exn pl
touchExpr e
failed <- gu_exn_is_raised exn
if failed
then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
@@ -687,6 +699,7 @@ functions p =
fptr <- wrapMapItorCallback (getFunctions ref)
(#poke GuMapItor, fn) itor fptr
pgf_iter_functions (pgf p) itor exn
touchPGF p
freeHaskellFunPtr fptr
fs <- readIORef ref
return (reverse fs)
@@ -709,6 +722,7 @@ functionsByCat p cat =
(#poke GuMapItor, fn) itor fptr
ccat <- newUtf8CString cat tmpPl
pgf_iter_functions_by_cat (pgf p) ccat itor exn
touchPGF p
freeHaskellFunPtr fptr
fs <- readIORef ref
return (reverse fs)
@@ -732,6 +746,7 @@ categories p =
fptr <- wrapMapItorCallback (getCategories ref)
(#poke GuMapItor, fn) itor fptr
pgf_iter_categories (pgf p) itor exn
touchPGF p
freeHaskellFunPtr fptr
cs <- readIORef ref
return (reverse cs)
@@ -748,8 +763,8 @@ categoryContext pgf cat = Nothing -- !!! not implemented yet TODO
-----------------------------------------------------------------------------
-- Helper functions
fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> a -> IO [(Expr, Float)]
fromPgfExprEnum enum fpl master =
fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> IO () -> IO [(Expr, Float)]
fromPgfExprEnum enum fpl touch =
do pgfExprProb <- alloca $ \ptr ->
withForeignPtr fpl $ \pl ->
do gu_enum_next enum ptr pl
@@ -758,9 +773,9 @@ fromPgfExprEnum enum fpl master =
then do finalizeForeignPtr fpl
return []
else do expr <- (#peek PgfExprProb, expr) pgfExprProb
ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl master)
ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl touch)
prob <- (#peek PgfExprProb, prob) pgfExprProb
return ((Expr expr master,prob) : ts)
return ((Expr expr touch,prob) : ts)
-----------------------------------------------------------------------
-- Exceptions

40
src/runtime/haskell-bind/PGF2/Expr.hsc
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE ExistentialQuantification #-}
#include <pgf/pgf.h>
module PGF2.Expr where
@@ -30,20 +29,20 @@ data BindType =
-- they are not released prematurely we use the exprMaster to
-- store references to other Haskell objects
data Expr = forall a . Expr {expr :: PgfExpr, exprMaster :: a}
data Expr = Expr {expr :: PgfExpr, touchExpr :: Touch}
instance Show Expr where
show = showExpr []
-- | Constructs an expression by lambda abstraction
mkAbs :: BindType -> CId -> Expr -> Expr
mkAbs bind_type var (Expr body master) =
mkAbs bind_type var (Expr body bodyTouch) =
unsafePerformIO $ do
exprPl <- gu_new_pool
cvar <- newUtf8CString var exprPl
c_expr <- pgf_expr_abs cbind_type cvar body exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (exprFPl,body))
return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl))
where
cbind_type =
case bind_type of
@@ -52,7 +51,7 @@ mkAbs bind_type var (Expr body master) =
-- | Decomposes an expression into an abstraction and a body
unAbs :: Expr -> Maybe (BindType, CId, Expr)
unAbs (Expr expr master) =
unAbs (Expr expr touch) =
unsafePerformIO $ do
c_abs <- pgf_expr_unabs expr
if c_abs == nullPtr
@@ -60,7 +59,7 @@ unAbs (Expr expr master) =
else do bt <- fmap toBindType ((#peek PgfExprAbs, bind_type) c_abs)
var <- (#peek PgfExprAbs, id) c_abs >>= peekUtf8CString
c_body <- (#peek PgfExprAbs, body) c_abs
return (Just (bt, var, Expr c_body master))
return (Just (bt, var, Expr c_body touch))
where
toBindType :: CInt -> BindType
toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
@@ -78,13 +77,13 @@ mkApp fun args =
exprPl <- gu_new_pool
c_expr <- pgf_expr_apply papp exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (exprFPl,args))
return (Expr c_expr (mapM_ touchExpr args >> touchForeignPtr exprFPl))
where
len = length args
-- | Decomposes an expression into an application of a function
unApp :: Expr -> Maybe (Fun,[Expr])
unApp (Expr expr master) =
unApp (Expr expr touch) =
unsafePerformIO $
withGuPool $ \pl -> do
appl <- pgf_expr_unapply expr pl
@@ -94,7 +93,7 @@ unApp (Expr expr master) =
fun <- peekCString =<< (#peek PgfApplication, fun) appl
arity <- (#peek PgfApplication, n_args) appl :: IO CInt
c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
return $ Just (fun, [Expr c_arg master | c_arg <- c_args])
return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])
-- | Constructs an expression from a string literal
mkStr :: String -> Expr
@@ -104,16 +103,17 @@ mkStr str =
exprPl <- gu_new_pool
c_expr <- pgf_expr_string cstr exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr exprFPl)
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into a string literal
unStr :: Expr -> Maybe String
unStr (Expr expr master) =
unStr (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_STR)
if plit == nullPtr
then return Nothing
else do s <- peekUtf8CString (plit `plusPtr` (#offset PgfLiteralStr, val))
touch
return (Just s)
-- | Constructs an expression from an integer literal
@@ -123,16 +123,17 @@ mkInt val =
exprPl <- gu_new_pool
c_expr <- pgf_expr_int (fromIntegral val) exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr exprFPl)
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into an integer literal
unInt :: Expr -> Maybe Int
unInt (Expr expr master) =
unInt (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_INT)
if plit == nullPtr
then return Nothing
else do n <- peek (plit `plusPtr` (#offset PgfLiteralInt, val))
touch
return (Just (fromIntegral (n :: CInt)))
-- | Constructs an expression from a real number
@@ -142,16 +143,17 @@ mkFloat val =
exprPl <- gu_new_pool
c_expr <- pgf_expr_float (realToFrac val) exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr exprFPl)
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into a real number literal
unFloat :: Expr -> Maybe Double
unFloat (Expr expr master) =
unFloat (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_FLT)
if plit == nullPtr
then return Nothing
else do n <- peek (plit `plusPtr` (#offset PgfLiteralFlt, val))
touch
return (Just (realToFrac (n :: CDouble)))
-- | Constructs a meta variable as an expression
@@ -161,16 +163,17 @@ mkMeta id =
exprPl <- gu_new_pool
c_expr <- pgf_expr_meta (fromIntegral id) exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr exprFPl)
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into a meta variable
unMeta :: Expr -> Maybe Int
unMeta (Expr expr master) =
unMeta (Expr expr touch) =
unsafePerformIO $ do
c_meta <- pgf_expr_unmeta expr
if c_meta == nullPtr
then return Nothing
else do id <- (#peek PgfExprMeta, id) c_meta
touch
return (Just (fromIntegral (id :: CInt)))
-- | parses a 'String' as an expression
@@ -186,7 +189,7 @@ readExpr str =
status <- gu_exn_is_raised exn
if (not status && c_expr /= nullPtr)
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return $ Just (Expr c_expr exprFPl)
return $ Just (Expr c_expr (touchForeignPtr exprFPl))
else do gu_pool_free exprPl
return Nothing
@@ -202,6 +205,7 @@ showExpr scope e =
printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
pgf_print_expr (expr e) printCtxt 1 out exn
touchExpr e
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s

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

@@ -10,10 +10,12 @@ import Control.Exception
import GHC.Ptr
import Data.Int(Int32)
type Touch = IO ()
-- | An abstract data type representing multilingual grammar
-- in Portable Grammar Format.
data PGF = PGF {pgf :: Ptr PgfPGF, pgfMaster :: ForeignPtr GuPool}
data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF}
data PGF = PGF {pgf :: Ptr PgfPGF, touchPGF :: Touch}
data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch}
------------------------------------------------------------------
-- libgu API

18
src/runtime/haskell-bind/PGF2/Type.hsc
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE ExistentialQuantification #-}
#include <pgf/pgf.h>
module PGF2.Type where
@@ -15,7 +14,7 @@ import PGF2.FFI
-- which are allocated from other pools. In order to ensure that
-- they are not released prematurely we use the exprMaster to
-- store references to other Haskell objects
data Type = forall a . Type {typ :: PgfExpr, typMaster :: a}
data Type = Type {typ :: PgfExpr, touchType :: Touch}
-- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis
type Hypo = (BindType,CId,Type)
@@ -36,7 +35,7 @@ readType str =
status <- gu_exn_is_raised exn
if (not status && c_type /= nullPtr)
then do typFPl <- newForeignPtr gu_pool_finalizer typPl
return $ Just (Type c_type typFPl)
return $ Just (Type c_type (touchForeignPtr typFPl))
else do gu_pool_free typPl
return Nothing
@@ -45,13 +44,14 @@ readType str =
-- in the type in order reverse to the order
-- of binding.
showType :: [CId] -> Type -> String
showType scope (Type ty master) =
showType scope (Type ty touch) =
unsafePerformIO $
withGuPool $ \tmpPl ->
do (sb,out) <- newOut tmpPl
printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
pgf_print_type ty printCtxt 1 out exn
touch
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
@@ -72,7 +72,7 @@ mkType hypos cat exprs = unsafePerformIO $ do
(#poke PgfType, n_exprs) c_type n_exprs
pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs
typFPl <- newForeignPtr gu_pool_finalizer typPl
return (Type c_type (typFPl,hypos,exprs))
return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl))
where
pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO ()
pokeHypos c_hypo [] typPl = return ()
@@ -93,10 +93,12 @@ mkType hypos cat exprs = unsafePerformIO $ do
poke ptr e
pokeExprs (plusPtr ptr (#size PgfExpr)) es
touchHypo (_,_,ty) = touchType ty
-- | Decomposes a type into a list of hypothesises, a category and
-- a list of arguments for the category.
unType :: Type -> ([Hypo],CId,[Expr])
unType (Type c_type master) = unsafePerformIO $ do
unType (Type c_type touch) = unsafePerformIO $ do
cid <- (#peek PgfType, cid) c_type >>= peekUtf8CString
c_hypos <- (#peek PgfType, hypos) c_type
n_hypos <- (#peek GuSeq, len) c_hypos
@@ -111,7 +113,7 @@ unType (Type c_type master) = unsafePerformIO $ do
c_ty <- (#peek PgfHypo, type) c_hypo
bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n
return ((bt,cid,Type c_ty master) : hs)
return ((bt,cid,Type c_ty touch) : hs)
| otherwise = return []
toBindType :: CInt -> BindType
@@ -121,5 +123,5 @@ unType (Type c_type master) = unsafePerformIO $ do
peekExprs ptr i n
| i < n = do e <- peekElemOff ptr i
es <- peekExprs ptr (i+1) n
return (Expr e master : es)
return (Expr e touch : es)
| otherwise = return []

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

@@ -89,10 +89,11 @@ inTransaction sg f =
-- Expressions
insertExpr :: SG -> Expr -> IO SgId
insertExpr (SG sg) (Expr expr _) =
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
@@ -107,13 +108,14 @@ getExpr (SG sg) id = do
if c_expr == nullPtr
then do touchForeignPtr exprFPl
return Nothing
else do return $ Just (Expr c_expr exprFPl)
else do return $ Just (Expr c_expr (touchForeignPtr exprFPl))
queryExpr :: SG -> Expr -> IO [(SgId,Expr)]
queryExpr (SG sg) (Expr query _) =
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
@@ -135,7 +137,7 @@ queryExpr (SG sg) (Expr query _) =
return []
else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
rest <- fetchResults res exn
return ((key,Expr c_expr exprFPl) : rest)
return ((key,Expr c_expr (touchForeignPtr exprFPl)) : rest)
updateFtsIndex :: SG -> PGF -> IO ()
updateFtsIndex (SG sg) p = do
@@ -163,7 +165,7 @@ queryLinearization (SG sg) query = do
handle_sg_exn exn
if c_expr == nullPtr
then getExprs exprFPl exprPl exn ids
else do let e = Expr c_expr exprFPl
else do let e = Expr c_expr (touchForeignPtr exprFPl)
es <- getExprs exprFPl exprPl exn ids
return (e:es)
@@ -191,7 +193,7 @@ readTriple str =
return Nothing
showTriple :: Expr -> Expr -> Expr -> String
showTriple (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) =
showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
unsafePerformIO $
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
@@ -202,11 +204,12 @@ showTriple (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) =
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
peekCString s
insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) =
insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
@@ -214,6 +217,7 @@ insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) =
pokeElemOff triple 1 expr2
pokeElemOff triple 2 expr3
id <- sg_insert_triple sg triple exn
touch1 >> touch2 >> touch3
handle_sg_exn exn
return id
@@ -221,6 +225,7 @@ 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
@@ -230,11 +235,11 @@ getTriple (SG sg) id = do
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
return (Just (Expr c_expr1 touch
,Expr c_expr2 touch
,Expr c_expr3 touch
))
else do touchForeignPtr exprFPl
else do touch
return Nothing
queryTriple :: SG -> Maybe Expr -> Maybe Expr -> Maybe Expr -> IO [(SgId,Expr,Expr,Expr)]
@@ -252,8 +257,8 @@ queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 =
toCExpr Nothing = nullPtr
toCExpr (Just (Expr expr _)) = expr
fromCExpr c_expr exprFPl Nothing = Expr c_expr exprFPl
fromCExpr c_expr exprFPl (Just e) = e
fromCExpr c_expr touch Nothing = Expr c_expr touch
fromCExpr c_expr touch (Just e) = e
fetchResults res = do
exprPl <- gu_new_pool
@@ -273,15 +278,15 @@ queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 =
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 exprFPl mb_expr1
,fromCExpr c_expr2 exprFPl mb_expr2
,fromCExpr c_expr3 exprFPl mb_expr3) : rest)
return ((key,fromCExpr c_expr1 touch mb_expr1
,fromCExpr c_expr2 touch mb_expr2
,fromCExpr c_expr3 touch mb_expr3) : rest)
data Query = forall a . Query {query :: Ptr SgQuery, queryMaster :: a}