GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-17 00:39:32 -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

28
src/runtime/haskell/PGF2.hsc
View File

@@ -240,15 +240,39 @@ showPGF p =
getLincats ref itor key val exn = do
name <- bracket (pgf_print_ident key) free $ \c_text -> do
peekText c_text
fields <- allocaBytes (1*(#size size_t)) $ \pcounts -> do
(n_fields,n_lindefs,n_linrefs) <-
allocaBytes (3*(#size size_t)) $ \pcounts -> do
pgf_get_lincat_counts_internal val pcounts
n_fields <- peekElemOff pcounts 0
n_fields <- peekElemOff pcounts 0
n_lindefs <- peekElemOff pcounts 1
n_linrefs <- peekElemOff pcounts 2
return (n_fields,n_lindefs,n_linrefs)
fields <- allocaBytes (3*(#size size_t)) $ \pcounts -> do
forM (init [0..n_fields]) $ \i -> do
pgf_get_lincat_field_internal val i >>= peekText
let def = text "lincat" <+> (text name <+> char '=' <+> char '[' $$
nest 2 (vcat (map (text.show) fields)) $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
forM_ (init [0..n_lindefs]) $ \i -> do
sig <- bracket (pgf_print_lindef_sig_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
seqs <- forM (init [0..n_fields]) $ \j ->
bracket (pgf_print_lindef_seq_internal val i j) free $ \c_text -> do
fmap text (peekText c_text)
let def = text "lindef" <+> (sig <+> char '=' <+> char '[' $$
nest 2 (vcat seqs) $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
forM_ (init [0..n_linrefs]) $ \i -> do
sig <- bracket (pgf_print_linref_sig_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
seq <- bracket (pgf_print_linref_seq_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
let def = text "linref" <+> (sig <+> char '=' <+> char '[' $$
nest 2 seq $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
ppLins c = unsafePerformIO $ do
ref <- newIORef empty

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

@@ -111,6 +111,14 @@ foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO
foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lindef_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lindef_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_linref_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_linref_seq_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_get_lin_counts_internal :: Ptr () -> Ptr CSize -> IO ()
foreign import ccall pgf_print_lin_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
@@ -189,7 +197,7 @@ foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIfac
foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO ())
foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO ()
foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()

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

BIN
src/runtime/haskell/tests/basic.pgf
View File

Binary file not shown.

17
src/runtime/haskell/tests/basic.pmcfg
View File

@@ -14,11 +14,28 @@ concrete basic_cnc {
lincat N = [
"s"
]
lindef N : String(0) -> N(0) = [
<0,0>
]
linref N : ∀{i<2} . N(i) -> String(0) = [
<0,0>
]
lincat P = [
]
lindef P : String(0) -> P(0) = [
]
linref P : P(0) -> String(0) = [
]
lincat S = [
""
]
lindef S : String(0) -> S(0) = [
<0,0>
]
linref S : S(0) -> String(0) = [
<0,0>
]
lin c : ∀{i<2} . N(i) -> S(0) = [
<0,0>
]