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

compile lindef & linref rules

Browse Source
This commit is contained in:
krangelov
2021-12-06 15:47:57 +01:00
parent 0b8a1a0de8
commit d274f4856e
15 changed files with 420 additions and 122 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -216,13 +216,17 @@ data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
data Production = Production [(LVar,LIndex)] [PArg] LParam [[Symbol]]
deriving (Eq,Show)
createLincat :: Cat -> [String] -> Transaction Concr ()
createLincat name fields = Transaction $ \c_db c_abstr c_revision c_exn ->
createLincat :: Cat -> [String] -> [Production] -> [Production] -> Transaction Concr ()
createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn ->
let n_fields = length fields
in withText name $ \c_name ->
allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
withTexts c_fields 0 fields $
pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral n_fields) c_fields c_exn
withBuildLinIface (lindefs++linrefs) $ \c_build ->
pgf_create_lincat c_db c_abstr c_revision c_name
(fromIntegral n_fields) c_fields
(fromIntegral (length lindefs)) (fromIntegral (length linrefs))
c_build c_exn
where
withTexts p i [] f = f
withTexts p i (s:ss) f =
@@ -238,12 +242,16 @@ dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
createLin :: Fun -> [Production] -> Transaction Concr ()
createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn ->
withText name $ \c_name ->
withBuildLinIface prods $ \c_build ->
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
withBuildLinIface prods f =
allocaBytes (#size PgfBuildLinIface) $ \c_build ->
allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
(#poke PgfBuildLinIface, vtbl) c_build vtbl
(#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
f c_build
where
forM_ [] c_exn f = return ()
forM_ (x:xs) c_exn f = do