Incrementally display output of eval commands

Rather than waiting for the process to complete and then displaying its
output, `patat` now fetches the `stdout` and `stderr` as it becomes
available and refreshes the display.

This means that by default, **stderr is now displayed as well**.
To disable displaying `stderr`, you can add `stderr: false` to the eval
configuration, e.g.:

```yaml
patat:
  eval:
    bash:
      command: bash
      stderr: false
```

CHANGELOG.md

@@ -1,5 +1,25 @@
 # Changelog
 
+## 0.13.0.0 (unreleased)
+
+ *  Incrementally display output of `eval` commands (#132)
+
+    Rather than waiting for the process to complete and then displaying its
+    output, `patat` now fetches the `stdout` and `stderr` as it becomes
+    available and refreshes the display.
+
+    This means that by default, **stderr is now displayed as well**.
+    To disable displaying `stderr`, you can add `stderr: false` to the eval
+    configuration, e.g.:
+
+    ```yaml
+    patat:
+      eval:
+        bash:
+          command: bash
+          stderr: false
+    ```
+
 ## 0.12.0.1 (2024-09-28)
 
  *  Fix width of code blocks when using wide characters (#171)

README.md

@@ -720,7 +720,7 @@ attribute on a code block matches the evaluator, it will be used.
 code of presentations downloaded from the internet before running them if they
 contain `eval` settings.
 
-Aside from the command, there are three more options:
+Aside from the command, there are four more options:
 
  -  `fragment`: Introduce a pause (see [fragments](#fragmented-slides)) in
     between showing the original code block and the output.  Defaults to `true`.
@@ -732,6 +732,7 @@ Aside from the command, there are three more options:
      *  `code`: the default setting.
      *  `none`: no formatting applied.
      *  `inline`: no formatting applied and no trailing newline.
+ -  `stderr`: Include output from standard error.  Defaults to `true`.
  -  `wrap`: this is a deprecated name for `container`, used in version 0.11 and
     earlier.
 

lib/Patat/Eval.hs

@@ -2,34 +2,48 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 module Patat.Eval
-    ( eval
+    ( parseEvalBlocks
+
+    , evalVar
+    , evalActiveVars
+    , evalAllVars
     ) where
 
 
 --------------------------------------------------------------------------------
 import qualified Control.Concurrent.Async       as Async
-import           Control.Exception              (finally)
+import           Control.Exception              (IOException, catch, finally)
+import           Control.Monad                  (foldM, when)
+import           Control.Monad.State            (StateT, runStateT, state)
+import           Control.Monad.Writer           (Writer, runWriter, tell)
+import           Data.Foldable                  (for_)
 import qualified Data.HashMap.Strict            as HMS
+import qualified Data.IORef                     as IORef
+import           Data.List                      (foldl')
 import           Data.Maybe                     (maybeToList)
 import qualified Data.Text                      as T
 import qualified Data.Text.IO                   as T
+import           Patat.Eval.Internal
 import           Patat.Presentation.Instruction
 import           Patat.Presentation.Internal
-import           Patat.Presentation.Settings
 import           System.Exit                    (ExitCode (..))
 import qualified System.IO                      as IO
-import           System.IO.Unsafe               (unsafeInterleaveIO)
 import qualified System.Process                 as Process
 import qualified Text.Pandoc.Definition         as Pandoc
 
 
 --------------------------------------------------------------------------------
-eval :: Presentation -> IO Presentation
-eval presentation = case psEval (pSettings presentation) of
-    Nothing -> pure presentation
-    Just settings -> do
-        slides <- traverse (evalSlide settings) (pSlides presentation)
-        pure presentation {pSlides = slides}
+parseEvalBlocks :: Presentation -> Presentation
+parseEvalBlocks presentation =
+    let ((pres, varGen), evalBlocks) = runWriter $
+            runStateT work (pVarGen presentation) in
+    pres {pEvalBlocks = evalBlocks, pVarGen = varGen}
+  where
+    work = case psEval (pSettings presentation) of
+        Nothing -> pure presentation
+        Just settings -> do
+            slides <- traverse (evalSlide settings) (pSlides presentation)
+            pure presentation {pSlides = slides}
 
 
 --------------------------------------------------------------------------------
@@ -40,7 +54,13 @@ lookupSettings classes settings = do
 
 
 --------------------------------------------------------------------------------
-evalSlide :: EvalSettingsMap -> Slide -> IO Slide
+-- | Monad used for identifying and extracting the evaluation blocks from a
+-- presentation.
+type ExtractEvalM a = StateT VarGen (Writer (HMS.HashMap Var EvalBlock)) a
+
+
+--------------------------------------------------------------------------------
+evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide
 evalSlide settings slide = case slideContent slide of
     TitleSlide _ _ -> pure slide
     ContentSlide instrs0 -> do
@@ -51,40 +71,35 @@ evalSlide settings slide = case slideContent slide of
 --------------------------------------------------------------------------------
 evalInstruction
     :: EvalSettingsMap -> Instruction Pandoc.Block
-    -> IO [Instruction Pandoc.Block]
+    -> ExtractEvalM [Instruction Pandoc.Block]
 evalInstruction settings instr = case instr of
     Pause         -> pure [Pause]
     ModifyLast i  -> map ModifyLast <$> evalInstruction settings i
     Append []     -> pure [Append []]
     Append blocks -> concat <$> traverse (evalBlock settings) blocks
+    AppendVar v   ->
+        -- Should not happen since we don't do recursive evaluation.
+        pure [AppendVar v]
     Delete        -> pure [Delete]
 
 
 --------------------------------------------------------------------------------
-evalBlock :: EvalSettingsMap -> Pandoc.Block -> IO [Instruction Pandoc.Block]
+evalBlock
+    :: EvalSettingsMap -> Pandoc.Block
+    -> ExtractEvalM [Instruction Pandoc.Block]
 evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt)
     | [s@EvalSettings {..}] <- lookupSettings classes settings = do
-        out <- unsafeInterleaveIO $ do
-            EvalResult {..} <-  evalCode s txt
-            pure $ case erExitCode of
-                ExitSuccess -> erStdout
-                ExitFailure i ->
-                    evalCommand <> ": exit code " <> T.pack (show i) <> "\n" <>
-                    erStderr
-        let fmt = "eval"
-            blocks = case evalContainer of
-                EvalContainerCode   -> [Pandoc.CodeBlock attr out]
-                EvalContainerNone   -> [Pandoc.RawBlock fmt out]
-                EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt out]]
+        var <- state freshVar
+        tell $ HMS.singleton var $ EvalBlock s attr txt Nothing
         pure $ case (evalFragment, evalReplace) of
-            (False, True) -> [Append blocks]
-            (False, False) -> [Append (orig : blocks)]
+            (False, True) -> [AppendVar var]
+            (False, False) -> [Append [orig], AppendVar var]
             (True, True) ->
                 [ Append [orig], Pause
-                , Delete, Append blocks
+                , Delete, AppendVar var
                 ]
             (True, False) ->
-                [Append [orig], Pause, Append blocks]
+                [Append [orig], Pause, AppendVar var]
     | _ : _ : _ <- lookupSettings classes settings =
         let msg = "patat eval matched multiple settings for " <>
                 T.intercalate "," classes in
@@ -94,30 +109,78 @@ evalBlock _ block =
 
 
 --------------------------------------------------------------------------------
-data EvalResult = EvalResult
-    { erExitCode :: !ExitCode
-    , erStdout   :: !T.Text
-    , erStderr   :: !T.Text
-    } deriving (Show)
+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
 
 
 --------------------------------------------------------------------------------
-evalCode :: EvalSettings -> T.Text -> IO EvalResult
-evalCode EvalSettings {..} input = do
-    let proc = (Process.shell $ T.unpack evalCommand)
-            { Process.std_in  = Process.CreatePipe
-            , Process.std_out = Process.CreatePipe
-            , Process.std_err = Process.CreatePipe
+evalVar :: Var -> ([Pandoc.Block] -> IO ()) -> Presentation -> IO Presentation
+evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of
+    Nothing -> pure presentation
+    Just EvalBlock {..} | Just _ <- ebAsync -> pure presentation
+    Just eb@EvalBlock {..} -> do
+        let EvalSettings {..} = ebSettings
+
+        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
+                , Process.std_out = Process.CreatePipe
+                , Process.std_err = Process.CreatePipe
+                }
+        (Just hIn, Just hOut, Just hErr, hProc) <- Process.createProcess proc
+        async <- Async.async $
+            Async.withAsync (T.hPutStr hIn ebInput `finally` IO.hClose hIn) $ \_ ->
+            Async.withAsync (drainLines True hOut) $ \outAsync ->
+            Async.withAsync (drainLines evalStderr hErr) $ \errAsync ->
+            Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do
+            erExitCode <- Async.wait exitCodeAsync
+            _ <- Async.wait outAsync
+            _ <- Async.wait errAsync
+            case erExitCode of
+                ExitSuccess -> pure ()
+                ExitFailure i -> writeChunk $
+                    evalCommand <> ": exit code " <> T.pack (show i) <> "\n"
+        pure presentation
+            { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks
             }
+  where
+    evalBlocks = pEvalBlocks presentation
+
 
-    (Just hIn, Just hOut, Just hErr, hProc) <- Process.createProcess proc
 
-    Async.withAsync (T.hPutStr hIn input `finally` IO.hClose hIn) $ \_ ->
-        Async.withAsync (T.hGetContents hOut) $ \outAsync ->
-        Async.withAsync (T.hGetContents hErr) $ \errAsync ->
-        Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do
+--------------------------------------------------------------------------------
+evalActiveVars
+    :: (Var -> [Pandoc.Block] -> IO ()) -> Presentation -> IO Presentation
+evalActiveVars update presentation = foldM
+    (\p var -> evalVar var (update var) p)
+    presentation
+    (activeVars presentation)
 
-        erExitCode <- Async.wait exitCodeAsync
-        erStdout <- Async.wait outAsync
-        erStderr <- Async.wait errAsync
-        pure $ EvalResult {..}
+
+--------------------------------------------------------------------------------
+evalAllVars :: Presentation -> IO Presentation
+evalAllVars pres = do
+    updates <- IORef.newIORef []
+
+    let forceEvalVar pres0 var = do
+            pres1 <- evalVar
+                var
+                (\u -> IORef.atomicModifyIORef' updates (\l -> (l ++ [u], ())))
+                pres0
+            case HMS.lookup var (pEvalBlocks pres1) of
+                Nothing -> pure pres1
+                Just eb -> do
+                    for_ (ebAsync eb) Async.wait
+                    IORef.atomicModifyIORef' updates $ \l ->
+                        ([], foldl' (\p u -> updateVar var u p) pres1 l)
+
+    foldM forceEvalVar pres (HMS.keys (pEvalBlocks pres))

lib/Patat/Eval/Internal.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+module Patat.Eval.Internal
+    ( EvalBlocks
+    , EvalBlock (..)
+    , renderEvalBlock
+    ) where
+
+
+--------------------------------------------------------------------------------
+import qualified Control.Concurrent.Async       as Async
+import qualified Data.HashMap.Strict            as HMS
+import qualified Data.Text                      as T
+import           Patat.Presentation.Instruction
+import           Patat.Presentation.Settings
+import qualified Text.Pandoc                    as Pandoc
+
+
+--------------------------------------------------------------------------------
+type EvalBlocks = HMS.HashMap Var EvalBlock
+
+
+--------------------------------------------------------------------------------
+-- | Block that needs to be evaluated.
+data EvalBlock = EvalBlock
+    { ebSettings :: !EvalSettings
+    , ebAttr     :: !Pandoc.Attr
+    , ebInput    :: !T.Text
+    , ebAsync    :: !(Maybe (Async.Async ()))
+    }
+
+
+--------------------------------------------------------------------------------
+renderEvalBlock :: EvalBlock -> T.Text -> [Pandoc.Block]
+renderEvalBlock EvalBlock {..} out = case evalContainer ebSettings of
+    EvalContainerCode   -> [Pandoc.CodeBlock ebAttr out]
+    EvalContainerNone   -> [Pandoc.RawBlock fmt out]
+    EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt out]]
+  where
+    fmt = "eval"

lib/Patat/Main.hs

@@ -24,6 +24,7 @@ import qualified Options.Applicative              as OA
 import qualified Options.Applicative.Help.Pretty  as OA.PP
 import           Patat.AutoAdvance
 import qualified Patat.EncodingFallback           as EncodingFallback
+import qualified Patat.Eval                       as Eval
 import qualified Patat.Images                     as Images
 import           Patat.Presentation
 import qualified Patat.Presentation.Comments      as Comments
@@ -160,15 +161,15 @@ main = do
             OA.parserFailure parserPrefs parserInfo
             (OA.ShowHelpText Nothing) mempty
 
-    errOrPres <- readPresentation filePath
+    errOrPres <- readPresentation zeroVarGen filePath
     pres      <- either (errorAndExit . return) return errOrPres
     let settings = pSettings pres
 
     unless (oForce options) assertAnsiFeatures
 
     if oDump options then
-        EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $
-        dumpPresentation pres
+        EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ do
+        Eval.evalAllVars pres >>= dumpPresentation
     else
         -- (Maybe) initialize images backend.
         withMaybeHandle Images.withHandle (psImages settings) $ \images ->
@@ -209,15 +210,20 @@ loop app@App {..} = do
         (pEncodingFallback aPresentation)
         (activeSpeakerNotes aPresentation)
 
-    size <- getPresentationSize aPresentation
+    -- Start necessary eval blocks
+    presentation <- Eval.evalActiveVars
+        (\v -> Chan.writeChan aCommandChan . PresentationCommand . UpdateVar v)
+        aPresentation
+
+    size <- getPresentationSize presentation
     Ansi.clearScreen
     Ansi.setCursorPosition 0 0
     cleanup <- case aView of
-        PresentationView -> case displayPresentation size aPresentation of
+        PresentationView -> case displayPresentation size presentation of
             DisplayDoc doc    -> drawDoc doc
             DisplayImage path -> drawImg size path
         ErrorView err -> drawDoc $
-                displayPresentationError size aPresentation err
+                displayPresentationError size presentation err
         TransitionView tr -> do
             drawMatrix (tiSize tr) . fst . NonEmpty.head $ tiFrames tr
             pure mempty
@@ -234,11 +240,11 @@ loop app@App {..} = do
                     loop app {aView = TransitionView tr1}
                 Nothing -> loop app {aView = PresentationView}
         PresentationCommand c -> do
-            update <- updatePresentation c aPresentation
+            update <- updatePresentation c presentation
             case update of
                 ExitedPresentation       -> return ()
                 UpdatedPresentation pres
-                    | Just tgen <- mbTransition c size aPresentation pres -> do
+                    | Just tgen <- mbTransition c size presentation pres -> do
                         tr <- tgen
                         scheduleTransitionTick tr
                         loop app
@@ -251,7 +257,7 @@ loop app@App {..} = do
     drawDoc doc = EncodingFallback.withHandle
         IO.stdout (pEncodingFallback aPresentation) $
         PP.putDoc doc $> mempty
-    drawImg size path =case aImages of
+    drawImg size path = case aImages of
         Nothing -> drawDoc $ displayPresentationError
             size aPresentation "image backend not initialized"
         Just img -> do