mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-09-28 13:13:37 -06:00
Diophantine grammars in the runtime
This commit is contained in:
Krasimir Angelov
@@ -73,7 +73,7 @@ module PGF2 (-- * PGF
|
||||
graphvizAbstractTree, graphvizParseTree,
|
||||
Labels, getDepLabels,
|
||||
graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
|
||||
graphvizWordAlignment, graphvizLRAutomaton,
|
||||
graphvizWordAlignment,
|
||||
|
||||
-- * Concrete syntax
|
||||
ConcName,Concr,languages,language,concreteName,languageCode,concreteFlag,
|
||||
@@ -363,19 +363,14 @@ showPGF p =
|
||||
modifyIORef ref (\doc -> doc $$ text def)
|
||||
|
||||
ppConcr name c = unsafePerformIO $ do
|
||||
(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
|
||||
doc1 <- ppLincats c
|
||||
doc2 <- ppLins c
|
||||
return (text "concrete" <+> text name <+> char '{' $$
|
||||
nest 2 (doc1 $$
|
||||
doc2 $$
|
||||
(text "sequences" <+> char '{' $$
|
||||
nest 2 doc3 $$
|
||||
char '}')) $$
|
||||
doc2) $$
|
||||
char '}')
|
||||
|
||||
ppLincats seq_ids c = do
|
||||
ppLincats c = do
|
||||
ref <- newIORef empty
|
||||
(allocaBytes (#size PgfItor) $ \itor ->
|
||||
bracket (wrapItorCallback (getLincats ref)) freeHaskellFunPtr $ \fptr ->
|
||||
@@ -402,15 +397,15 @@ showPGF p =
|
||||
char ']')
|
||||
modifyIORef ref $ (\doc -> doc $$ def)
|
||||
forM_ (init [0..n_lindefs]) $ \i -> do
|
||||
def <- bracket (pgf_print_lindef_internal seq_ids val i) free $ \c_text -> do
|
||||
def <- bracket (pgf_print_lindef_internal 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 seq_ids val i) free $ \c_text -> do
|
||||
def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do
|
||||
fmap text (peekText c_text)
|
||||
modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def)
|
||||
|
||||
ppLins seq_ids c = do
|
||||
ppLins c = do
|
||||
ref <- newIORef empty
|
||||
(allocaBytes (#size PgfItor) $ \itor ->
|
||||
bracket (wrapItorCallback (getLins ref)) freeHaskellFunPtr $ \fptr ->
|
||||
@@ -421,30 +416,13 @@ showPGF p =
|
||||
where
|
||||
getLins :: IORef Doc -> ItorCallback
|
||||
getLins ref itor key val exn = do
|
||||
n_prods <- pgf_get_lin_get_prod_count val
|
||||
n_prods <- pgf_get_lin_rules_count val
|
||||
forM_ (init [0..n_prods]) $ \i -> do
|
||||
def <- bracket (pgf_print_lin_internal seq_ids val i) free $ \c_text -> do
|
||||
def <- bracket (pgf_print_lin_internal 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
|
||||
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 nullPtr))
|
||||
doc <- readIORef ref
|
||||
return (seq_ids, doc)
|
||||
where
|
||||
getSequences :: IORef Doc -> SequenceItorCallback
|
||||
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)
|
||||
return 0
|
||||
|
||||
-- | The abstract language name is the name of the top-level
|
||||
-- abstract module
|
||||
abstractName :: PGF -> AbsName
|
||||
@@ -830,8 +808,7 @@ fullFormLexicon c = unsafePerformIO $ do
|
||||
withForeignPtr (c_revision c) $ \c_revision -> do
|
||||
(#poke PgfSequenceItor, fn) itor1 fptr1
|
||||
(#poke PgfMorphoCallback, fn) itor2 fptr2
|
||||
seq_ids <- withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2)
|
||||
pgf_release_phrasetable_ids seq_ids)
|
||||
withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2))
|
||||
fmap (reverse2 []) (readIORef ref)
|
||||
where
|
||||
getSequences ref _ seq_id val exn = do
|
||||
@@ -1484,15 +1461,6 @@ graphvizDependencyTree
|
||||
-> String -- ^ Rendered output in the specified format
|
||||
graphvizDependencyTree format debug mlab mclab concr t = error "TODO: graphvizDependencyTree"
|
||||
|
||||
graphvizLRAutomaton :: Concr -> String
|
||||
graphvizLRAutomaton c =
|
||||
unsafePerformIO $
|
||||
withForeignPtr (c_revision c) $ \c_revision ->
|
||||
bracket (withPgfExn "graphvizLRAutomaton" (pgf_graphviz_lr_automaton (c_db c) c_revision)) free $ \c_text ->
|
||||
if c_text == nullPtr
|
||||
then return ""
|
||||
else peekText c_text
|
||||
|
||||
---------------------- should be a separate module?
|
||||
|
||||
-- visualization with latex output. AR Nov 2015
|
||||
|
||||
@@ -48,7 +48,6 @@ data PgfSequenceItor
|
||||
data PgfProbsCallback
|
||||
data PgfMorphoCallback
|
||||
data PgfCohortsCallback
|
||||
data PgfPhrasetableIds
|
||||
data PgfExprEnum
|
||||
data PgfAlignmentPhrase
|
||||
|
||||
@@ -150,26 +149,22 @@ foreign import ccall "wrapper" wrapCohortsCallback :: Wrapper CohortsCallback
|
||||
|
||||
foreign import ccall pgf_lookup_cohorts :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfCohortsCallback -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO (Ptr PgfPhrasetableIds)
|
||||
foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO ()
|
||||
|
||||
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 PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
|
||||
foreign import ccall pgf_print_lindef_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_print_linref_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
|
||||
foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize
|
||||
foreign import ccall pgf_get_lin_rules_count :: Ptr () -> IO CSize
|
||||
|
||||
foreign import ccall pgf_print_lin_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_print_sequence_internal :: CSize -> Ptr () -> IO (Ptr PgfText)
|
||||
foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_sequence_get_text_internal :: Ptr () -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_release_phrasetable_ids :: Ptr PgfPhrasetableIds -> IO ()
|
||||
|
||||
type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback
|
||||
@@ -244,7 +239,7 @@ foreign import ccall "dynamic" callLinBuilder1 :: Dynamic (Ptr PgfLinBuilderIfac
|
||||
|
||||
foreign import ccall "dynamic" callLinBuilder2 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr PgfExn -> IO ())
|
||||
|
||||
foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
|
||||
foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
|
||||
|
||||
foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
|
||||
|
||||
@@ -318,8 +313,6 @@ foreign import ccall pgf_graphviz_parse_tree :: Ptr PgfDB -> Ptr Concr -> Stable
|
||||
|
||||
foreign import ccall pgf_graphviz_word_alignment :: Ptr PgfDB -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> Ptr PgfPrintContext -> Ptr PgfMarshaller -> Ptr PgfGraphvizOptions -> Ptr PgfExn -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_graphviz_lr_automaton :: Ptr PgfDB -> Ptr Concr -> Ptr PgfExn -> IO (Ptr PgfText)
|
||||
|
||||
|
||||
-----------------------------------------------------------------------
|
||||
-- Texts
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module PGF2.Transactions
|
||||
( -- transactions
|
||||
TxnID
|
||||
@@ -18,15 +19,14 @@ module PGF2.Transactions
|
||||
, setAbstractFlag
|
||||
|
||||
-- concrete syntax
|
||||
, Token, SeqId, LIndex, LVar, LParam(..)
|
||||
, PArg(..), Symbol(..), Production(..)
|
||||
, Token, LIndex, LVar, LParam(..)
|
||||
, PArg(..), Symbol(..), Rule(..)
|
||||
|
||||
, createConcrete
|
||||
, alterConcrete
|
||||
, dropConcrete
|
||||
, mergePGF
|
||||
, setConcreteFlag
|
||||
, SeqTable
|
||||
, createLincat
|
||||
, dropLincat
|
||||
, createLin, alterLin
|
||||
@@ -251,21 +251,23 @@ data Symbol
|
||||
| SymALL_CAPIT -- the special ALL_CAPIT token
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
type Quantifiers = [(LVar,Int)]
|
||||
data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol]
|
||||
deriving (Eq,Show)
|
||||
|
||||
data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
|
||||
deriving (Eq,Show)
|
||||
|
||||
data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId]
|
||||
deriving (Eq,Show)
|
||||
|
||||
type SeqTable = Seq.Seq (Either [Symbol] SeqId)
|
||||
|
||||
createLincat :: Cat -> [String] -> [Production] -> [Production] -> SeqTable -> Transaction Concr SeqTable
|
||||
createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> 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 $
|
||||
withBuildLinIface (lindefs++linrefs) seqtbl $ \c_build ->
|
||||
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))
|
||||
@@ -282,27 +284,25 @@ dropLincat name = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
pgf_drop_lincat c_db c_abstr c_revision c_name c_exn
|
||||
|
||||
createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
|
||||
createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
createLin :: Fun -> [Rule] -> Transaction Concr ()
|
||||
createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
withBuildLinIface prods seqtbl $ \c_build ->
|
||||
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
|
||||
withBuildLinIface rules $ \c_build ->
|
||||
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
|
||||
|
||||
alterLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
|
||||
alterLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
alterLin :: Fun -> [Rule] -> Transaction Concr ()
|
||||
alterLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
withBuildLinIface prods seqtbl $ \c_build ->
|
||||
pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
|
||||
withBuildLinIface rules $ \c_build ->
|
||||
pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
|
||||
|
||||
withBuildLinIface prods seqtbl f = do
|
||||
ref <- newIORef seqtbl
|
||||
withBuildLinIface rules f = do
|
||||
(allocaBytes (#size PgfBuildLinIface) $ \c_build ->
|
||||
allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
|
||||
bracket (wrapLinBuild (build ref)) freeHaskellFunPtr $ \c_callback -> do
|
||||
bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
|
||||
(#poke PgfBuildLinIface, vtbl) c_build vtbl
|
||||
(#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
|
||||
f c_build)
|
||||
readIORef ref
|
||||
where
|
||||
forM_ [] c_exn f = return ()
|
||||
forM_ (x:xs) c_exn f = do
|
||||
@@ -311,31 +311,23 @@ withBuildLinIface prods seqtbl f = do
|
||||
then f x >> forM_ xs c_exn f
|
||||
else return ()
|
||||
|
||||
build ref _ c_builder c_exn = do
|
||||
build _ c_builder c_exn = do
|
||||
vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder
|
||||
forM_ prods c_exn $ \(Production vars args res seqids) -> do
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
|
||||
callLinBuilder0 fun c_builder c_exn
|
||||
forM_ rules c_exn $ \(Rule vars res args lin_idx seq) -> do
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, start_rule) vtbl
|
||||
callLinBuilder2 fun c_builder (fromIntegral (length vars)) (fromIntegral (length seq)) c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl
|
||||
forM_ args c_exn $ \(PArg hypos param) ->
|
||||
callLParam (callLinBuilder3 fun c_builder (fromIntegral (length hypos))) param c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl
|
||||
callLParam (callLinBuilder3 fun c_builder (fromIntegral (length vars))) res c_exn
|
||||
forM_ args c_exn $ \arg ->
|
||||
callLParam (callLinBuilder3 fun c_builder) arg c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl
|
||||
callLParam (callLinBuilder3 fun c_builder) res c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, set_lin_idx) vtbl
|
||||
callLParam (callLinBuilder3 fun c_builder) lin_idx c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, add_variable) vtbl
|
||||
forM_ vars c_exn $ \(v,r) ->
|
||||
callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl
|
||||
seqtbl <- readIORef ref
|
||||
forM_ seqids c_exn $ \seqid ->
|
||||
case Seq.index seqtbl seqid of
|
||||
Left syms -> do fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
|
||||
callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
|
||||
forM_ syms c_exn (addSymbol c_builder vtbl c_exn)
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
|
||||
seqid' <- callLinBuilder7 fun c_builder c_exn
|
||||
writeIORef ref $! Seq.update seqid (Right (fromIntegral seqid')) seqtbl
|
||||
Right seqid -> do callLinBuilder1 fun c_builder (fromIntegral seqid) c_exn
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl
|
||||
forM_ seq c_exn (addSymbol c_builder vtbl c_exn)
|
||||
fun <- (#peek PgfLinBuilderIfaceVtbl, end_rule) vtbl
|
||||
callLinBuilder0 fun c_builder c_exn
|
||||
|
||||
addSymbol c_builder vtbl c_exn (SymCat d r) = do
|
||||
|
||||
Reference in New Issue
Block a user