added bracketedLinearizeAll

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,6 +909,51 @@ bracketedLinearize lang e = unsafePerformIO $
                            return []
                    else do ctree <- pgf_lzr_wrap_linref ctree pl
                            ref <- newIORef ([],[])
+                           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
+                                     if is_nonexist
+                                       then return []
+                                       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)
@@ -925,21 +970,14 @@ bracketedLinearize lang e = unsafePerformIO $
       (#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
+      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
-                           failed <- gu_exn_is_raised exn
+      return res
-                           if failed
-                             then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
-                                     if is_nonexist
-                                       then return []
-                                       else throwExn exn
-                             else do (_,bs) <- readIORef ref
-                                     return (reverse bs)
   where
     symbol_token ref _ c_token = do
       (stack,bs) <- readIORef ref