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 $