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

added createCategory, dropCategory

Browse Source
This commit is contained in:
krangelov
2021-09-09 17:33:25 +02:00
parent a44787fc4e
commit f7aad0c0e0
12 changed files with 141 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

35
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -118,6 +118,10 @@ foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr
foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> CSize -> Ptr PgfTypeHypo -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
-----------------------------------------------------------------------
-- Texts
@@ -310,7 +314,7 @@ foreign import ccall "dynamic"
foreign import ccall "wrapper"
wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun)
type DTypFun = Ptr PgfUnmarshaller -> CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
type DTypFun = Ptr PgfUnmarshaller -> CSize -> Ptr PgfTypeHypo -> Ptr PgfText -> CSize -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
foreign import ccall "dynamic"
callDTypFun :: FunPtr DTypFun -> DTypFun
@@ -397,21 +401,19 @@ marshaller = unsafePerformIO $ do
ty <- deRefStablePtr c_ty
case ty of
DTyp hypos cat es -> let n_hypos = length hypos
in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
in withHypos hypos $ \n_hypos c_hypos ->
withText cat $ \c_cat ->
mask_ $ do
marshalHypos c_hypos hypos
c_es <- mapM newStablePtr es
res <- withArray c_es $ \c_exprs -> do
fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
callDTypFun fun u
(fromIntegral n_hypos)
n_hypos
c_hypos
c_cat
(fromIntegral (length es))
c_exprs
mapM_ freeStablePtr c_es
freeHypos c_hypos n_hypos
return res
where
marshalHypos _ [] = return ()
@@ -533,3 +535,26 @@ marshalBindType Implicit = (#const PGF_BIND_TYPE_IMPLICIT)
unmarshalBindType :: (#type PgfBindType) -> BindType
unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
withHypos hypos f =
let n_hypos = length hypos
in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
mask_ $ do
marshalHypos c_hypos hypos
res <- f (fromIntegral n_hypos :: CSize) c_hypos
freeHypos n_hypos c_hypos
return res
where
marshalHypos _ [] = return ()
marshalHypos ptr ((bt,var,ty):hs) = do
(#poke PgfTypeHypo, bind_type) ptr (marshalBindType bt)
newText var >>= (#poke PgfTypeHypo, cid) ptr
newStablePtr ty >>= (#poke PgfTypeHypo, type) ptr
marshalHypos (ptr `plusPtr` (#size PgfTypeHypo)) hs
freeHypos 0 ptr = return ()
freeHypos n ptr = do
(#peek PgfTypeHypo, cid) ptr >>= free
(#peek PgfTypeHypo, type) ptr >>= freeStablePtr
freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo))

14
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -5,6 +5,8 @@ module PGF2.Transactions
, checkoutPGF
, createFunction
, dropFunction
, createCategory
, dropCategory
) where
import PGF2.FFI
@@ -116,3 +118,15 @@ dropFunction :: Fun -> Transaction ()
dropFunction name = Transaction $ \c_db c_revision c_exn ->
withText name $ \c_name -> do
pgf_drop_function c_db c_revision c_name c_exn
createCategory :: Fun -> [Hypo] -> Float -> Transaction ()
createCategory name hypos prob = Transaction $ \c_db c_revision c_exn ->
withText name $ \c_name ->
withHypos hypos $ \n_hypos c_hypos ->
withForeignPtr marshaller $ \m -> do
pgf_create_category c_db c_revision c_name n_hypos c_hypos prob m c_exn
dropCategory :: Cat -> Transaction ()
dropCategory name = Transaction $ \c_db c_revision c_exn ->
withText name $ \c_name -> do
pgf_drop_category c_db c_revision c_name c_exn