msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

get rid of the destructive updates for seq_ids

Browse Source
This commit is contained in:
Krasimir Angelov
2022-01-10 10:27:09 +01:00
parent 19f7fb8d5e
commit d87b3ce166
12 changed files with 191 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -223,16 +223,19 @@ showPGF p =
modifyIORef ref (\doc -> doc $$ text def)
ppConcr name c = unsafePerformIO $ do
doc <- prepareSequences c -- run first to update all seq_id
(seq_ids,doc3) <- prepareSequences c -- run first to update all seq_id
doc1 <- ppLincats seq_ids c
doc2 <- ppLins seq_ids c
pgf_release_phrasetable_ids seq_ids
return (text "concrete" <+> text name <+> char '{' $$
nest 2 (ppLincats c $$
ppLins c $$
nest 2 (doc1 $$
doc2 $$
(text "sequences" <+> char '{' $$
nest 2 doc $$
nest 2 doc3 $$
char '}')) $$
char '}')
ppLincats c = unsafePerformIO $ do
ppLincats seq_ids c = do
ref <- newIORef empty
(allocaBytes (#size PgfItor) $ \itor ->
bracket (wrapItorCallback (getLincats ref)) freeHaskellFunPtr $ \fptr ->
@@ -259,15 +262,15 @@ showPGF p =
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
forM_ (init [0..n_lindefs]) $ \i -> do
def <- bracket (pgf_print_lindef_internal val i) free $ \c_text -> do
def <- bracket (pgf_print_lindef_internal seq_ids val i) free $ \c_text -> do
fmap text (peekText c_text)
modifyIORef ref (\doc -> doc $$ text "lindef" <+> def)
forM_ (init [0..n_linrefs]) $ \i -> do
def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do
def <- bracket (pgf_print_linref_internal seq_ids val i) free $ \c_text -> do
fmap text (peekText c_text)
modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def)
ppLins c = unsafePerformIO $ do
ppLins seq_ids c = do
ref <- newIORef empty
(allocaBytes (#size PgfItor) $ \itor ->
bracket (wrapItorCallback (getLins ref)) freeHaskellFunPtr $ \fptr ->
@@ -280,23 +283,24 @@ showPGF p =
getLins ref itor key val exn = do
n_prods <- pgf_get_lin_get_prod_count val
forM_ (init [0..n_prods]) $ \i -> do
def <- bracket (pgf_print_lin_internal val i) free $ \c_text -> do
def <- bracket (pgf_print_lin_internal seq_ids val i) free $ \c_text -> do
fmap text (peekText c_text)
modifyIORef ref (\doc -> doc $$ text "lin" <+> def)
return ()
prepareSequences c = do
ref <- newIORef empty
(allocaBytes (#size PgfSequenceItor) $ \itor ->
bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr ->
withForeignPtr (c_revision c) $ \c_revision -> do
(#poke PgfSequenceItor, fn) itor fptr
withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor))
readIORef ref
seq_ids <- (allocaBytes (#size PgfSequenceItor) $ \itor ->
bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr ->
withForeignPtr (c_revision c) $ \c_revision -> do
(#poke PgfSequenceItor, fn) itor fptr
withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor))
doc <- readIORef ref
return (seq_ids, doc)
where
getSequences :: IORef Doc -> SequenceItorCallback
getSequences ref itor val exn = do
def <- bracket (pgf_print_sequence_internal val) free $ \c_text -> do
getSequences ref itor seq_id val exn = do
def <- bracket (pgf_print_sequence_internal seq_id val) free $ \c_text -> do
fmap text (peekText c_text)
modifyIORef ref $ (\doc -> doc $$ def)

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

@@ -46,6 +46,7 @@ data PgfLinBuilderIface
data PgfLinearizationOutputIface
data PgfGraphvizOptions
data PgfSequenceItor
data PgfPhrasetableIds
type Wrapper a = a -> IO (FunPtr a)
type Dynamic a = FunPtr a -> a
@@ -111,25 +112,27 @@ foreign import ccall pgf_iter_lincats :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -
foreign import ccall pgf_iter_lins :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -> Ptr PgfExn -> IO ()
type SequenceItorCallback = Ptr PgfSequenceItor -> Ptr () -> Ptr PgfExn -> IO ()
type SequenceItorCallback = Ptr PgfSequenceItor -> CSize -> Ptr () -> Ptr PgfExn -> IO ()
foreign import ccall "wrapper" wrapSequenceItorCallback :: Wrapper SequenceItorCallback
foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfExn -> IO ()
foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfExn -> IO (Ptr PgfPhrasetableIds)
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_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lindef_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_linref_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize
foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lin_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_sequence_internal :: Ptr () -> IO (Ptr PgfText)
foreign import ccall pgf_print_sequence_internal :: CSize -> Ptr () -> IO (Ptr PgfText)
foreign import ccall pgf_release_phrasetable_ids :: Ptr PgfPhrasetableIds -> IO ()
type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()