diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 97460de4d..07bbcbc96 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -18,7 +18,7 @@ module PGF2 (-- * CId PGF,readPGF,AbsName,abstractName,startCat, -- * Concrete syntax ConcName,Concr,languages,parse,parseWithHeuristics, - hasLinearization,linearize,alignWords, + hasLinearization,linearize,linearizeAll,alignWords, -- * Types Type(..), Hypo, functionType, -- * Trees @@ -456,6 +456,43 @@ linearize lang e = unsafePerformIO $ else do lin <- gu_string_buf_freeze sb pl peekCString lin +linearizeAll :: Concr -> Expr -> [String] +linearizeAll lang e = unsafePerformIO $ + withGuPool $ \pl -> + do exn <- gu_new_exn pl + cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl + failed <- gu_exn_is_raised exn + if failed + then throwExn exn + else collect cts exn pl + where + collect cts exn pl = do + ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl + peek ptr + if ctree == nullPtr + then return [] + else do (sb,out) <- newOut pl + ctree <- pgf_lzr_wrap_linref ctree pl + pgf_lzr_linearize_simple (concr lang) ctree 0 out exn pl + 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 cts exn pl + else throwExn exn + else do lin <- gu_string_buf_freeze sb pl + s <- peekCString lin + ss <- collect cts exn pl + return (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 <- peekCString c_msg + throwIO (PGFError msg) + else throwIO (PGFError "The abstract tree cannot be linearized") + alignWords :: Concr -> Expr -> [(String, [Int])] alignWords lang e = unsafePerformIO $ withGuPool $ \pl -> diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index d78502561..4f7618388 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -90,6 +90,7 @@ data PgfMorphoCallback data PgfPrintContext data PgfType data PgfCallbacksMap +data PgfCncTree foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) @@ -139,6 +140,15 @@ foreign import ccall "pgf/pgf.h pgf_has_linearization" foreign import ccall "pgf/pgf.h pgf_linearize" pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO () +foreign import ccall "pgf/pgf.h pgf_lzr_concretize" + pgf_lzr_concretize :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum) + +foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref" + pgf_lzr_wrap_linref :: Ptr PgfCncTree -> Ptr GuPool -> IO (Ptr PgfCncTree) + +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_align_words" pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq)