diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 186aa2b31..9583eb7b5 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -146,8 +146,7 @@ showPGF p = exn <- gu_new_exn tmpPl pgf_print (pgf p) out exn touchPGF p - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb -- | List of all languages available in the grammar. languages :: PGF -> Map.Map ConcName Concr @@ -418,9 +417,7 @@ graphvizAbstractTree p opts e = c_opts <- newGraphvizOptions tmpPl opts pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s - + peekUtf8CStringBuf sb graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String graphvizParseTree c opts e = @@ -431,8 +428,7 @@ graphvizParseTree c opts e = c_opts <- newGraphvizOptions tmpPl opts pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String graphvizWordAlignment cs opts e = @@ -444,8 +440,7 @@ graphvizWordAlignment cs opts e = c_opts <- newGraphvizOptions tmpPl opts pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions) newGraphvizOptions pool opts = do @@ -750,8 +745,7 @@ linearize lang e = unsafePerformIO $ msg <- peekUtf8CString c_msg throwIO (PGFError msg) else throwIO (PGFError "The abstract tree cannot be linearized") - else do lin <- gu_string_buf_freeze sb pl - peekUtf8CString lin + else do peekUtf8CStringBuf sb -- | Generates all possible linearizations of an expression linearizeAll :: Concr -> Expr -> [String] @@ -780,8 +774,7 @@ linearizeAll lang e = unsafePerformIO $ if is_nonexist then collect cts exn pl else throwExn exn pl - else do lin <- gu_string_buf_freeze sb tmpPl - s <- peekUtf8CString lin + else do s <- peekUtf8CStringBuf sb ss <- collect cts exn pl return (s:ss) @@ -841,8 +834,7 @@ tabularLinearizeAll lang e = unsafePerformIO $ if is_nonexist then collectTable lang ctree (lin_idx+1) labels exn tmpPl else throwExn exn - else do lin <- gu_string_buf_freeze sb tmpPl - s <- peekUtf8CString lin + else do s <- peekUtf8CStringBuf sb ss <- collectTable lang ctree (lin_idx+1) labels exn tmpPl return ((label,s):ss) diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index 096d15bfa..d66b51c2b 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -259,8 +259,7 @@ showExpr scope e = exn <- gu_new_exn tmpPl pgf_print_expr (expr e) printCtxt 1 out exn touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext) newPrintCtxt [] pool = return nullPtr diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index 39b18fcf3..563522a5d 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -106,6 +106,12 @@ foreign import ccall unsafe "gu/enum.h gu_enum_next" foreign import ccall unsafe "gu/string.h gu_string_buf_freeze" gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString +foreign import ccall unsafe "gu/string.h gu_string_buf_data" + gu_string_buf_data :: Ptr GuStringBuf -> IO CString + +foreign import ccall unsafe "gu/string.h gu_string_buf_length" + gu_string_buf_length :: Ptr GuStringBuf -> IO CSizeT + foreign import ccall unsafe "gu/utf8.h gu_utf8_decode" gu_utf8_decode :: Ptr CString -> IO GuUCS @@ -186,6 +192,12 @@ peekUtf8CStringLen ptr len = cs <- decode pptr end return (((toEnum . fromEnum) x) : cs) +peekUtf8CStringBuf :: Ptr GuStringBuf -> IO String +peekUtf8CStringBuf sbuf = do + ptr <- gu_string_buf_data sbuf + len <- gu_string_buf_length sbuf + peekUtf8CStringLen ptr (fromIntegral len) + pokeUtf8CString :: String -> CString -> IO () pokeUtf8CString s ptr = alloca $ \pptr -> diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index 57e7eeaa9..1228accd7 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -52,8 +52,7 @@ showType scope (Type ty touch) = exn <- gu_new_exn tmpPl pgf_print_type ty printCtxt 0 out exn touch - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb -- | creates a type from a list of hypothesises, a category and -- a list of arguments for the category. The operation @@ -137,5 +136,4 @@ showContext scope hypos = exn <- gu_new_exn tmpPl pgf_print_context c_hypos printCtxt out exn mapM_ touchHypo hypos - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc index 791abc767..aa23de3a0 100644 --- a/src/runtime/haskell-bind/SG.hsc +++ b/src/runtime/haskell-bind/SG.hsc @@ -206,8 +206,7 @@ showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = pokeElemOff triple 2 expr3 pgf_print_expr_tuple 3 triple printCtxt out exn touch1 >> touch2 >> touch3 - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + peekUtf8CStringBuf sb insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =