use interleaved IO for peeking strings when possible

src/runtime/haskell-bind/PGF2.hsc

@@ -140,13 +140,13 @@ readPGF fpath =
 
 showPGF :: PGF -> String
 showPGF p =
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print (pgf p) out exn
-         touchPGF p
-         peekUtf8CStringBuf sb
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print (pgf p) out exn
+    touchPGF p
+    peekUtf8CStringBufResult sb tmpPl
 
 -- | List of all languages available in the grammar.
 languages :: PGF -> Map.Map ConcName Concr
@@ -410,37 +410,37 @@ graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
 -- | Renders an abstract syntax tree in a Graphviz format.
 graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String
 graphvizAbstractTree p opts e =
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         c_opts <- newGraphvizOptions tmpPl opts
-         pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
-         touchExpr e
-         peekUtf8CStringBuf sb
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    c_opts <- newGraphvizOptions tmpPl opts
+    pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
 
 graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
 graphvizParseTree c opts e =
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         c_opts <- newGraphvizOptions tmpPl opts
-         pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
-         touchExpr e
-         peekUtf8CStringBuf sb
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    exn <- gu_new_exn tmpPl
+    c_opts <- newGraphvizOptions tmpPl opts
+    pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
 
 graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String
 graphvizWordAlignment cs opts e =
   unsafePerformIO $
-    withGuPool $ \tmpPl ->
     withArrayLen (map concr cs) $ \n_concrs ptr ->
-      do (sb,out) <- newOut tmpPl
+      do tmpPl <- gu_new_pool
+         (sb,out) <- newOut tmpPl
          exn <- gu_new_exn tmpPl
          c_opts <- newGraphvizOptions tmpPl opts
          pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn
          touchExpr e
-         peekUtf8CStringBuf sb
+         peekUtf8CStringBufResult sb tmpPl
 
 newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions)
 newGraphvizOptions pool opts = do

src/runtime/haskell-bind/PGF2/Expr.hsc

@@ -252,14 +252,14 @@ foreign import ccall "wrapper"
 -- of binding.
 showExpr :: [CId] -> Expr -> String
 showExpr scope e = 
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print_expr (expr e) printCtxt 1 out exn
-         touchExpr e
-         peekUtf8CStringBuf sb
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print_expr (expr e) printCtxt 1 out exn
+    touchExpr e
+    peekUtf8CStringBufResult sb tmpPl
 
 newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
 newPrintCtxt []     pool = return nullPtr

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

@@ -15,6 +15,7 @@ import Control.Exception
 import GHC.Ptr
 import Data.Int
 import Data.Word
+import System.IO.Unsafe
 
 type Touch = IO ()
 
@@ -198,6 +199,23 @@ peekUtf8CStringBuf sbuf = do
   len <- gu_string_buf_length sbuf
   peekUtf8CStringLen ptr (fromIntegral len)
 
+peekUtf8CStringBufResult :: Ptr GuStringBuf -> Ptr GuPool -> IO String
+peekUtf8CStringBufResult sbuf pool = do
+  fptr <- newForeignPtr gu_pool_finalizer pool
+  ptr <- gu_string_buf_data sbuf
+  len <- gu_string_buf_length sbuf
+  pptr <- gu_malloc pool (#size GuString*)
+  poke pptr ptr >> decode fptr pptr (ptr `plusPtr` fromIntegral len)
+  where
+    decode fptr pptr end = do
+      ptr <- peek pptr
+      if ptr >= end
+        then return []
+        else do x <- gu_utf8_decode pptr
+                cs <- unsafeInterleaveIO (decode fptr pptr end)
+                touchForeignPtr fptr
+                return (((toEnum . fromEnum) x) : cs)
+
 pokeUtf8CString :: String -> CString -> IO ()
 pokeUtf8CString s ptr =
   alloca $ \pptr ->

src/runtime/haskell-bind/PGF2/Type.hsc

@@ -45,14 +45,14 @@ readType str =
 -- of binding.
 showType :: [CId] -> Type -> String
 showType scope (Type ty touch) = 
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print_type ty printCtxt 0 out exn
-         touch
-         peekUtf8CStringBuf sb
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print_type ty printCtxt 0 out exn
+    touch
+    peekUtf8CStringBufResult sb tmpPl
 
 -- | creates a type from a list of hypothesises, a category and 
 -- a list of arguments for the category. The operation 
@@ -128,12 +128,12 @@ unType (Type c_type touch) = unsafePerformIO $ do
 -- of binding.
 showContext :: [CId] -> [Hypo] -> String
 showContext scope hypos =
-  unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
-         printCtxt <- newPrintCtxt scope tmpPl
-         exn <- gu_new_exn tmpPl
-         pgf_print_context c_hypos printCtxt out exn
-         mapM_ touchHypo hypos
-         peekUtf8CStringBuf sb
+  unsafePerformIO $ do
+    tmpPl <- gu_new_pool
+    (sb,out) <- newOut tmpPl
+    c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
+    printCtxt <- newPrintCtxt scope tmpPl
+    exn <- gu_new_exn tmpPl
+    pgf_print_context c_hypos printCtxt out exn
+    mapM_ touchHypo hypos
+    peekUtf8CStringBufResult sb tmpPl

src/runtime/haskell-bind/SG.hsc

@@ -196,17 +196,17 @@ readTriple str =
 showTriple :: Expr -> Expr -> Expr -> String
 showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
   unsafePerformIO $
-    withGuPool $ \tmpPl ->
-      withTriple $ \triple -> do
-         (sb,out) <- newOut tmpPl
-         let printCtxt = nullPtr
-         exn <- gu_new_exn tmpPl
-         pokeElemOff triple 0 expr1
-         pokeElemOff triple 1 expr2
-         pokeElemOff triple 2 expr3
-         pgf_print_expr_tuple 3 triple printCtxt out exn
-         touch1 >> touch2 >> touch3
-         peekUtf8CStringBuf sb
+    withTriple $ \triple -> do
+      tmpPl <- gu_new_pool
+      (sb,out) <- newOut tmpPl
+      let printCtxt = nullPtr
+      exn <- gu_new_exn tmpPl
+      pokeElemOff triple 0 expr1
+      pokeElemOff triple 1 expr2
+      pokeElemOff triple 2 expr3
+      pgf_print_expr_tuple 3 triple printCtxt out exn
+      touch1 >> touch2 >> touch3
+      peekUtf8CStringBufResult sb tmpPl
 
 insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
 insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =