Permalink
Browse files

Work around lazy bytestring bug in ghc

  • Loading branch information...
gregorycollins committed May 22, 2010
1 parent eeb4cb4 commit ddb29e7c24823a8fe514616bd84060f3d20a352e
Showing with 28 additions and 20 deletions.
  1. +28 −20 src/Text/Templating/Heist/Splices/Markdown.hs
@@ -2,9 +2,9 @@
module Text.Templating.Heist.Splices.Markdown where
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as L
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
import Data.Maybe
import Control.Concurrent
import Control.Exception (evaluate, throwIO)
@@ -31,12 +31,12 @@ instance Show PandocMissingException where
instance Exception PandocMissingException
-data MarkdownException = MarkdownException L.ByteString
+data MarkdownException = MarkdownException ByteString
deriving (Typeable)
instance Show MarkdownException where
show (MarkdownException e) =
- "Markdown error: pandoc replied:\n\n" ++ L.unpack e
+ "Markdown error: pandoc replied:\n\n" ++ BC.unpack e
instance Exception MarkdownException
@@ -57,13 +57,13 @@ markdownSplice = do
tree <- getParamNode
markup <- liftIO $
case getAttribute tree "file" of
- Just f -> pandoc (fromJust pdMD) $ B.unpack f
+ Just f -> pandoc (fromJust pdMD) $ BC.unpack f
Nothing -> pandocBS (fromJust pdMD) $ textContent tree
let ee = parse' heistExpatOptions markup
case ee of
(Left e) -> throw $ MarkdownException
- $ L.pack ("Error parsing markdown output: " ++ show e)
+ $ BC.pack ("Error parsing markdown output: " ++ show e)
(Right n) -> return [n]
@@ -72,10 +72,9 @@ pandoc pandocPath inputFile = do
(ex, sout, serr) <- readProcessWithExitCode' pandocPath args ""
when (isFail ex) $ throw $ MarkdownException serr
- return $ B.concat $ L.toChunks
- $ L.concat [ "<div class=\"markdown\">\n"
- , sout
- , "\n</div>" ]
+ return $ BC.concat [ "<div class=\"markdown\">\n"
+ , sout
+ , "\n</div>" ]
where
isFail ExitSuccess = False
@@ -91,10 +90,9 @@ pandocBS pandocPath s = do
(ex, sout, serr) <- readProcessWithExitCode' pandocPath args s
when (isFail ex) $ throw $ MarkdownException serr
- return $ B.concat $ L.toChunks
- $ L.concat [ "<div class=\"markdown\">\n"
- , sout
- , "\n</div>" ]
+ return $ BC.concat [ "<div class=\"markdown\">\n"
+ , sout
+ , "\n</div>" ]
where
isFail ExitSuccess = False
@@ -107,21 +105,28 @@ readProcessWithExitCode'
:: FilePath -- ^ command to run
-> [String] -- ^ any arguments
-> ByteString -- ^ standard input
- -> IO (ExitCode,L.ByteString,L.ByteString) -- ^ exitcode, stdout, stderr
+ -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr
readProcessWithExitCode' cmd args input = do
(Just inh, Just outh, Just errh, pid) <-
createProcess (proc cmd args){ std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe }
outMVar <- newEmptyMVar
+ outM <- newEmptyMVar
+ errM <- newEmptyMVar
+
-- fork off a thread to start consuming stdout
- out <- L.hGetContents outh
- forkIO $ evaluate (L.length out) >> putMVar outMVar ()
+ forkIO $ do
+ out <- B.hGetContents outh
+ putMVar outM out
+ putMVar outMVar ()
-- fork off a thread to start consuming stderr
- err <- L.hGetContents errh
- forkIO $ evaluate (L.length err) >> putMVar outMVar ()
+ forkIO $ do
+ err <- B.hGetContents errh
+ putMVar errM err
+ putMVar outMVar ()
-- now write and flush any input
when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
@@ -135,6 +140,9 @@ readProcessWithExitCode' cmd args input = do
-- wait on the process
ex <- waitForProcess pid
+ out <- readMVar outM
+ err <- readMVar errM
+
return (ex, out, err)

0 comments on commit ddb29e7

Please sign in to comment.