diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c index 5317830fb..d7873f584 100644 --- a/src/runtime/c/pgf/pgf.c +++ b/src/runtime/c/pgf/pgf.c @@ -163,6 +163,20 @@ pgf_category_prob(PgfPGF* pgf, PgfCId catname) return abscat->prob; } +PGF_API GuString* +pgf_category_fields(PgfConcr* concr, PgfCId catname, size_t *n_lins) +{ + PgfCncCat* cnccat = + gu_map_get(concr->cnccats, catname, PgfCncCat*); + if (!cnccat) { + *n_lins = 0; + return NULL; + } + + *n_lins = cnccat->n_lins; + return &cnccat->labels; +} + PGF_API GuString pgf_language_code(PgfConcr* concr) { diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index c0a64f01d..5dbe2e2e1 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -95,6 +95,9 @@ pgf_category_context(PgfPGF *gr, PgfCId catname); PGF_API_DECL prob_t pgf_category_prob(PgfPGF* pgf, PgfCId catname); +PGF_API GuString* +pgf_category_fields(PgfConcr* concr, PgfCId catname, size_t *n_lins); + PGF_API_DECL void pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err); diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index d3f61595c..a84f7511c 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -61,7 +61,7 @@ module PGF2 (-- * PGF -- ** Linearization linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,bracketedLinearizeAll, FId, BracketedString(..), showBracketedString, flattenBracketedString, - printName, + printName, categoryFields, alignWords, -- ** Parsing @@ -988,6 +988,7 @@ tabularLinearizeAll lang e = unsafePerformIO $ exn <- gu_new_exn tmpPl cts <- pgf_lzr_concretize (concr lang) (expr e) exn tmpPl failed <- gu_exn_is_raised exn + touchConcr lang if failed then throwExn exn else collect cts exn tmpPl @@ -1033,6 +1034,28 @@ tabularLinearizeAll lang e = unsafePerformIO $ throwIO (PGFError msg) else do throwIO (PGFError "The abstract tree cannot be linearized") +categoryFields :: Concr -> Cat -> Maybe [String] +categoryFields lang cat = + unsafePerformIO $ do + withGuPool $ \tmpPl -> do + p_n_lins <- gu_malloc tmpPl (#size size_t) + c_cat <- newUtf8CString cat tmpPl + c_fields <- pgf_category_fields (concr lang) c_cat p_n_lins + if c_fields == nullPtr + then do touchConcr lang + return Nothing + else do len <- peek p_n_lins + fs <- peekFields len c_fields + touchConcr lang + return (Just fs) + where + peekFields 0 ptr = return [] + peekFields len ptr = do + f <- peek ptr >>= peekUtf8CString + fs <- peekFields (len-1) (ptr `plusPtr` (#size GuString)) + return (f:fs) + + -- | BracketedString represents a sentence that is linearized -- as usual but we also want to retain the ''brackets'' that -- mark the beginning and the end of each constituent. diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index 2db9577a0..b348f5012 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -313,6 +313,9 @@ foreign import ccall "pgf/pgf.h pgf_category_context" foreign import ccall "pgf/pgf.h pgf_category_prob" pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t) +foreign import ccall "pgf/pgf.h pgf_category_fields" + pgf_category_fields :: Ptr PgfConcr -> CString -> Ptr CSize -> IO (Ptr CString) + foreign import ccall "pgf/pgf.h pgf_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()