Refactor, more deterministic tests

lib/Patat/Eval.hs

@@ -13,7 +13,7 @@ module Patat.Eval
 --------------------------------------------------------------------------------
 import qualified Control.Concurrent.Async       as Async
 import           Control.Exception              (IOException, catch, finally)
-import           Control.Monad                  (foldM, forever, when)
+import           Control.Monad                  (foldM, when)
 import           Control.Monad.State            (StateT, runStateT, state)
 import           Control.Monad.Writer           (Writer, runWriter, tell)
 import           Data.Foldable                  (for_)
@@ -108,6 +108,14 @@ evalBlock _ block =
     pure [Append [block]]
 
 
+--------------------------------------------------------------------------------
+newAccum :: Monoid m => (m -> IO ()) -> IO (m -> IO ())
+newAccum f = do
+    ref <- IORef.newIORef mempty
+    pure $ \x ->
+        IORef.atomicModifyIORef' ref (\y -> let z = y <> x in (z, z)) >>= f
+
+
 --------------------------------------------------------------------------------
 evalVar :: Var -> ([Pandoc.Block] -> IO ()) -> Presentation -> IO Presentation
 evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of
@@ -116,18 +124,12 @@ evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of
     Just eb@EvalBlock {..} -> do
         let EvalSettings {..} = ebSettings
 
-        outRef <- IORef.newIORef ""
-        let writeLine l = do
-                t <- IORef.atomicModifyIORef' outRef $ \o ->
-                    let n = if T.null o then l else o <> "\n" <> l in
-                    (n, n)
-                writeOutput $ renderEvalBlock eb t
-
-        let drainLines copy h = catch
-                (forever $ do
-                    l <- T.hGetLine h
-                    when copy $ writeLine l)
-                ((\_ -> pure ()) :: IOException -> IO ())
+        writeChunk <- newAccum (writeOutput . renderEvalBlock eb)
+        let drainLines copy h = do
+                c <- catch (T.hGetChunk h) ((\_ -> pure "") :: IOException -> IO T.Text)
+                when (c /= "") $ do
+                    when copy $ writeChunk c
+                    drainLines copy h
 
         let proc = (Process.shell $ T.unpack evalCommand)
                 { Process.std_in  = Process.CreatePipe
@@ -145,8 +147,8 @@ evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of
             _ <- Async.wait errAsync
             case erExitCode of
                 ExitSuccess -> pure ()
-                ExitFailure i -> writeLine $
-                    evalCommand <> ": exit code " <> T.pack (show i)
+                ExitFailure i -> writeChunk $
+                    evalCommand <> ": exit code " <> T.pack (show i) <> "\n"
         pure presentation
             { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks
             }

tests/golden/inputs/eval08.md

@@ -21,15 +21,18 @@ patat:
 
 ~~~{.implicitStderr}
 echo "Hello stdout"
+sleep 0.1
 echo "Hello stderr" >&2
 ~~~
 
 ~~~{.withStderr}
 echo "Hello stdout"
+sleep 0.1
 echo "Hello stderr" >&2
 ~~~
 
 ~~~{.withoutStderr}
 echo "Hello stdout"
+sleep 0.1
 echo "Hello stderr" >&2
 ~~~