added bracketedLinearize in the Haskell binding

src/runtime/haskell-bind/PGF2.hsc

@@ -14,6 +14,7 @@
 -------------------------------------------------
 
 #include <pgf/pgf.h>
+#include <pgf/linearizer.h>
 #include <gu/enum.h>
 #include <gu/exn.h>
 
@@ -51,7 +52,7 @@ module PGF2 (-- * PGF
              -- * Concrete syntax
              ConcName,Concr,languages,
              -- ** Linearization
-             linearize,linearizeAll,tabularLinearize,
+             linearize,linearizeAll,tabularLinearize,bracketedLinearize,
              FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString,
 
              alignWords,
@@ -725,6 +726,84 @@ flattenBracketedString :: BracketedString -> [String]
 flattenBracketedString (Leaf w)              = [w]
 flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss
 
+bracketedLinearize :: Concr -> Expr -> [BracketedString]
+bracketedLinearize 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 do ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl
+                                              peek ptr
+                 if ctree == nullPtr
+                   then do touchExpr e
+                           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_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 nullPtr
+                              (#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_meta
+                           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)
+  where
+    symbol_token ref _ c_token = do
+      (stack,bs) <- readIORef ref
+      token <- peekUtf8CString c_token
+      writeIORef ref (stack,Leaf token : bs)
+
+    begin_phrase ref _ c_cat c_fid c_lindex c_fun = do
+      (stack,bs) <- readIORef ref
+      writeIORef ref (bs:stack,[])
+
+    end_phrase ref _ c_cat c_fid c_lindex c_fun = do
+      (bs':stack,bs) <- readIORef ref
+      cat <- peekUtf8CString c_cat
+      let fid    = fromIntegral c_fid
+      let lindex = fromIntegral c_lindex
+      fun <- peekUtf8CString c_fun
+      writeIORef ref (stack, Bracket cat fid lindex fun (reverse bs) : bs')
+
+    symbol_ne exn _ = do
+      gu_exn_raise exn gu_exn_type_PgfLinNonExist
+      return ()
+
+    symbol_meta ref _ meta_id = do
+      (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")
+
 alignWords :: Concr -> Expr -> [(String, [Int])]
 alignWords lang e = unsafePerformIO $
   withGuPool $ \pl ->

src/runtime/haskell-bind/PGF2/FFI.hs

@@ -55,6 +55,9 @@ foreign import ccall "gu/exn.h gu_exn_is_raised"
 foreign import ccall "gu/exn.h gu_exn_caught_"
   gu_exn_caught :: Ptr GuExn -> CString -> IO Bool
 
+foreign import ccall "gu/exn.h gu_exn_raise_"
+  gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ())
+
 gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString
 
 gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString
@@ -144,6 +147,7 @@ type PgfType = Ptr ()
 data PgfCallbacksMap
 data PgfOracleCallback
 data PgfCncTree
+data PgfLinFuncs
 
 foreign import ccall "pgf/pgf.h pgf_read"
   pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
@@ -202,9 +206,29 @@ foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref"
 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_lzr_linearize"
+  pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO ()
+
 foreign import ccall "pgf/pgf.h pgf_lzr_get_table"
   pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CInt -> Ptr (Ptr CString) -> IO ()
 
+type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO ()
+type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CInt -> CString -> IO ()
+type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
+type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO ()
+
+foreign import ccall "wrapper"
+  wrapSymbolTokenCallback :: SymbolTokenCallback -> IO (FunPtr SymbolTokenCallback)
+
+foreign import ccall "wrapper"
+  wrapPhraseCallback :: PhraseCallback -> IO (FunPtr PhraseCallback)
+
+foreign import ccall "wrapper"
+  wrapSymbolNonExistCallback :: NonExistCallback -> IO (FunPtr NonExistCallback)
+
+foreign import ccall "wrapper"
+  wrapSymbolMetaCallback :: MetaCallback -> IO (FunPtr MetaCallback)
+
 foreign import ccall "pgf/pgf.h pgf_align_words"
   pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq)