added bracketedLinearizeAll

1 files changed, 69 insertions, 31 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 64ac1953c..186aa2b31 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -58,7 +58,7 @@ module PGF2 (-- * PGF
              ConcName,Concr,languages,concreteName,languageCode,
 
              -- ** Linearization
-             linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,
+             linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,bracketedLinearizeAll,
              FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString,
              printName,
 
@@ -909,29 +909,8 @@ bracketedLinearize lang e = unsafePerformIO $
                            return []
                    else do ctree <- pgf_lzr_wrap_linref ctree pl
                            ref <- newIORef ([],[])
-                           allocaBytes (#size PgfLinFuncs) $ \pLinFuncs  ->
-                            alloca $ \ppLinFuncs -> do
-                              fptr_symbol_token <- wrapSymbolTokenCallback (symbol_token ref)
-                              fptr_begin_phrase <- wrapPhraseCallback (begin_phrase ref)
-                              fptr_end_phrase   <- wrapPhraseCallback (end_phrase ref)
-                              fptr_symbol_ne    <- wrapSymbolNonExistCallback (symbol_ne exn)
-                              fptr_symbol_bind  <- wrapSymbolBindCallback (symbol_bind ref)
-                              fptr_symbol_meta  <- wrapSymbolMetaCallback (symbol_meta ref)
-                              (#poke PgfLinFuncs, symbol_token) pLinFuncs fptr_symbol_token
-                              (#poke PgfLinFuncs, begin_phrase) pLinFuncs fptr_begin_phrase
-                              (#poke PgfLinFuncs, end_phrase)   pLinFuncs fptr_end_phrase
-                              (#poke PgfLinFuncs, symbol_ne)    pLinFuncs fptr_symbol_ne
-                              (#poke PgfLinFuncs, symbol_bind)  pLinFuncs fptr_symbol_bind
-                              (#poke PgfLinFuncs, symbol_capit) pLinFuncs nullPtr
-                              (#poke PgfLinFuncs, symbol_meta)  pLinFuncs fptr_symbol_meta
-                              poke ppLinFuncs pLinFuncs
-                              pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs pl
-                              freeHaskellFunPtr fptr_symbol_token
-                              freeHaskellFunPtr fptr_begin_phrase
-                              freeHaskellFunPtr fptr_end_phrase
-                              freeHaskellFunPtr fptr_symbol_ne
-                              freeHaskellFunPtr fptr_symbol_bind
-                              freeHaskellFunPtr fptr_symbol_meta
+                           withBracketLinFuncs ref exn $ \ppLinFuncs ->
+                             pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs pl
                            failed <- gu_exn_is_raised exn
                            if failed
                              then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
@@ -940,6 +919,65 @@ bracketedLinearize lang e = unsafePerformIO $
                                        else throwExn exn
                              else do (_,bs) <- readIORef ref
                                      return (reverse bs)
+
+bracketedLinearizeAll :: Concr -> Expr -> [[BracketedString]]
+bracketedLinearizeAll 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 do touchExpr e
+                 throwExn exn
+         else do ref <- newIORef ([],[])
+                 bss <- withBracketLinFuncs ref exn $ \ppLinFuncs ->
+                          collect ref cts ppLinFuncs exn pl
+                 touchExpr e
+                 return bss
+  where
+    collect ref cts ppLinFuncs exn pl = withGuPool $ \tmpPl -> do
+      ctree <- alloca $ \ptr -> do gu_enum_next cts ptr tmpPl
+                                   peek ptr
+      if ctree == nullPtr
+        then return []
+        else do ctree <- pgf_lzr_wrap_linref ctree pl
+                pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs 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 ref cts ppLinFuncs exn pl
+                            else throwExn exn
+                   else do (_,bs) <- readIORef ref
+                           writeIORef ref ([],[])
+                           bss <- collect ref cts ppLinFuncs exn pl
+                           return (reverse bs : bss)
+
+withBracketLinFuncs ref exn f =
+  allocaBytes (#size PgfLinFuncs) $ \pLinFuncs  ->
+    alloca $ \ppLinFuncs -> do
+      fptr_symbol_token <- wrapSymbolTokenCallback (symbol_token ref)
+      fptr_begin_phrase <- wrapPhraseCallback (begin_phrase ref)
+      fptr_end_phrase   <- wrapPhraseCallback (end_phrase ref)
+      fptr_symbol_ne    <- wrapSymbolNonExistCallback (symbol_ne exn)
+      fptr_symbol_bind  <- wrapSymbolBindCallback (symbol_bind ref)
+      fptr_symbol_meta  <- wrapSymbolMetaCallback (symbol_meta ref)
+      (#poke PgfLinFuncs, symbol_token) pLinFuncs fptr_symbol_token
+      (#poke PgfLinFuncs, begin_phrase) pLinFuncs fptr_begin_phrase
+      (#poke PgfLinFuncs, end_phrase)   pLinFuncs fptr_end_phrase
+      (#poke PgfLinFuncs, symbol_ne)    pLinFuncs fptr_symbol_ne
+      (#poke PgfLinFuncs, symbol_bind)  pLinFuncs fptr_symbol_bind
+      (#poke PgfLinFuncs, symbol_capit) pLinFuncs nullPtr
+      (#poke PgfLinFuncs, symbol_meta)  pLinFuncs fptr_symbol_meta
+      poke ppLinFuncs pLinFuncs
+      res <- f ppLinFuncs
+      freeHaskellFunPtr fptr_symbol_token
+      freeHaskellFunPtr fptr_begin_phrase
+      freeHaskellFunPtr fptr_end_phrase
+      freeHaskellFunPtr fptr_symbol_ne
+      freeHaskellFunPtr fptr_symbol_bind
+      freeHaskellFunPtr fptr_symbol_meta
+      return res
   where
     symbol_token ref _ c_token = do
       (stack,bs) <- readIORef ref
@@ -971,13 +1009,13 @@ bracketedLinearize lang e = unsafePerformIO $
       (stack,bs) <- readIORef ref
       writeIORef ref (stack,Leaf "?" : bs)
 
-    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")
+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")
 
 alignWords :: Concr -> Expr -> [(String, [Int])]
 alignWords lang e = unsafePerformIO $