added linearizeAll in the Haskell bindings

2 files changed, 48 insertions, 1 deletions

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)