diff options
Diffstat (limited to 'src/runtime')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 50 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hs | 3 |
2 files changed, 52 insertions, 1 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index e50fdd4b1..60b805acd 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -51,7 +51,7 @@ module PGF2 (-- * PGF -- * Concrete syntax ConcName,Concr,languages, -- ** Linearization - linearize,linearizeAll, + linearize,linearizeAll,tabularLinearize, FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString, alignWords, @@ -640,6 +640,54 @@ linearizeAll lang e = unsafePerformIO $ else do gu_pool_free pl throwIO (PGFError "The abstract tree cannot be linearized") +-- | Generates a table of linearizations for an expression +tabularLinearize :: Concr -> Expr -> Map.Map String String +tabularLinearize lang e = unsafePerformIO $ + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + cts <- pgf_lzr_concretize (concr lang) (expr e) exn tmpPl + failed <- gu_exn_is_raised exn + if failed + then throwExn exn + else do ctree <- alloca $ \ptr -> do gu_enum_next cts ptr tmpPl + peek ptr + if ctree == nullPtr + then do touchExpr e + return Map.empty + else do labels <- alloca $ \p_n_lins -> + alloca $ \p_labels -> do + pgf_lzr_get_table (concr lang) ctree p_n_lins p_labels + n_lins <- peek p_n_lins + labels <- peek p_labels + labels <- peekArray (fromIntegral n_lins) labels + labels <- mapM peekCString labels + return labels + lins <- collect lang ctree 0 labels exn tmpPl + return (Map.fromList lins) + where + collect lang ctree lin_idx [] exn tmpPl = return [] + collect lang ctree lin_idx (label:labels) exn tmpPl = do + (sb,out) <- newOut tmpPl + pgf_lzr_linearize_simple (concr lang) ctree lin_idx out exn tmpPl + failed <- gu_exn_is_raised exn + if failed + then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist + if is_nonexist + then collect lang ctree (lin_idx+1) labels exn tmpPl + else throwExn exn + else do lin <- gu_string_buf_freeze sb tmpPl + s <- peekUtf8CString lin + ss <- collect lang ctree (lin_idx+1) labels exn tmpPl + return ((label,s):ss) + + throwExn exn = do + is_exn <- gu_exn_caught exn gu_exn_type_PgfExn + if is_exn + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekUtf8CString c_msg + throwIO (PGFError msg) + else do throwIO (PGFError "The abstract tree cannot be linearized") + type FId = Int type LIndex = Int diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 77e075495..ae217b46a 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -202,6 +202,9 @@ foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref" foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple" pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () +foreign import ccall "pgf/pgf.h pgf_lzr_get_table" + pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CInt -> Ptr (Ptr CString) -> IO () + foreign import ccall "pgf/pgf.h pgf_align_words" pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq) |