Refactor

lib/Patat/Eval.hs

@@ -4,8 +4,8 @@
 module Patat.Eval
     ( parseEvalBlocks
 
-    , UpdateEvalBlock
-    , updateEvalBlock
+    , UpdateVar
+    , updateVar
     , evalVar
     , evalVars
     , forceEval
@@ -91,7 +91,7 @@ evalBlock
 evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt)
     | [s@EvalSettings {..}] <- lookupSettings classes settings = do
         var <- state freshVar
-        tell $ HMS.singleton var $ EvalBlock s attr txt Nothing mempty
+        tell $ HMS.singleton var $ EvalBlock s attr txt Nothing
         pure $ case (evalFragment, evalReplace) of
             (False, True) -> [AppendVar var]
             (False, False) -> [Append [orig], AppendVar var]
@@ -110,29 +110,39 @@ evalBlock _ block =
 
 
 --------------------------------------------------------------------------------
-data UpdateEvalBlock = UpdateEvalBlock Int Var T.Text
+data UpdateVar = UpdateVar Int Var [Pandoc.Block]
     deriving (Eq, Show)
 
 
 --------------------------------------------------------------------------------
-updateEvalBlock :: UpdateEvalBlock -> Presentation -> Presentation
-updateEvalBlock (UpdateEvalBlock version var out) pres
+updateVar ::UpdateVar -> Presentation -> Presentation
+updateVar (UpdateVar version var out) pres
     | version /= pVersion pres = pres
-    | otherwise                = pres
-        { pEvalBlocks = HMS.adjust adjust var $ pEvalBlocks pres
-        }
-  where
-    addLine x = if T.null x then out else x <> "\n" <> out
-    adjust b = b {ebOutput = addLine (ebOutput b)}
+    | otherwise                = pres {pVars = HMS.insert var out $ pVars pres}
 
 
 --------------------------------------------------------------------------------
-evalVar :: Var -> (UpdateEvalBlock -> IO ()) -> Presentation -> IO Presentation
+evalVar :: Var -> (UpdateVar -> 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
+
+        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 $ UpdateVar (pVersion presentation) var
+                    (renderEvalBlock eb t)
+
+        let copyLines h = catch
+                (forever $ do
+                    l <- T.hGetLine h
+                    writeLine l)
+                ((\_ -> pure ()) :: IOException -> IO ())
+
         let proc = (Process.shell $ T.unpack evalCommand)
                 { Process.std_in  = Process.CreatePipe
                 , Process.std_out = Process.CreatePipe
@@ -141,35 +151,28 @@ evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of
         (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 (getLines hOut) $ \outAsync ->
-            Async.withAsync (getLines hErr) $ \errAsync ->
+            Async.withAsync (copyLines hOut) $ \outAsync ->
+            Async.withAsync (copyLines 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 -> writeOutput $ mkUpdateEvalBlock $
+                ExitFailure i -> writeLine $
                     evalCommand <> ": exit code " <> T.pack (show i)
         pure presentation
             { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks
             }
   where
     evalBlocks = pEvalBlocks presentation
 
-    mkUpdateEvalBlock = UpdateEvalBlock (pVersion presentation) var
-
-    getLines h = catch
-        (forever $ do
-            l <- T.hGetLine h
-            writeOutput $ mkUpdateEvalBlock l)
-        ((\_ -> pure ()) :: IOException -> IO ())
 
 
 --------------------------------------------------------------------------------
 evalVars
     :: Foldable f
-    => f Var -> (UpdateEvalBlock -> IO ()) -> Presentation -> IO Presentation
+    => f Var -> (UpdateVar -> IO ()) -> Presentation -> IO Presentation
 evalVars vars update presentation =
     foldM (\p var -> evalVar var update p) presentation vars
 
@@ -189,6 +192,6 @@ forceEval pres = do
                 Just eb -> do
                     for_ (ebAsync eb) Async.wait
                     IORef.atomicModifyIORef' updates $ \l ->
-                        ([], foldl' (\p u -> updateEvalBlock u p) pres1 l)
+                        ([], foldl' (\p u -> updateVar u p) pres1 l)
 
     foldM forceEvalVar pres (HMS.keys (pEvalBlocks pres))

lib/Patat/Eval/Internal.hs

@@ -3,7 +3,7 @@
 module Patat.Eval.Internal
     ( EvalBlocks
     , EvalBlock (..)
-    , evalBlockToBlocks
+    , renderEvalBlock
     ) where
 
 
@@ -27,15 +27,14 @@ data EvalBlock = EvalBlock
     , ebAttr     :: !Pandoc.Attr
     , ebInput    :: !T.Text
     , ebAsync    :: !(Maybe (Async.Async ()))
-    , ebOutput   :: !T.Text
     }
 
 
 --------------------------------------------------------------------------------
-evalBlockToBlocks :: EvalBlock -> [Pandoc.Block]
-evalBlockToBlocks EvalBlock {..} = case evalContainer ebSettings of
-    EvalContainerCode   -> [Pandoc.CodeBlock ebAttr ebOutput]
-    EvalContainerNone   -> [Pandoc.RawBlock fmt ebOutput]
-    EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt ebOutput]]
+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

@@ -213,7 +213,7 @@ loop app@App {..} = do
     -- Start necessary eval blocks
     presentation <- Eval.evalVars
         (activeVars aPresentation)
-        (Chan.writeChan aCommandChan . PresentationCommand . UpdateEvalBlock)
+        (Chan.writeChan aCommandChan . PresentationCommand . UpdateVar)
         aPresentation
 
     size <- getPresentationSize presentation

lib/Patat/Presentation/Interactive.hs

@@ -32,7 +32,7 @@ data PresentationCommand
     | Last
     | Reload
     | Seek Int
-    | UpdateEvalBlock Eval.UpdateEvalBlock
+    | UpdateVar Eval.UpdateVar
     | UnknownCommand String
     deriving (Eq, Show)
 
@@ -98,17 +98,17 @@ updatePresentation
     :: PresentationCommand -> Presentation -> IO UpdatedPresentation
 
 updatePresentation cmd presentation = case cmd of
-    Exit              -> pure ExitedPresentation
-    Forward           -> pure $ goToSlide $ \(s, f) -> (s, f + 1)
-    Backward          -> pure $ goToSlide $ \(s, f) -> (s, f - 1)
-    SkipForward       -> pure $ goToSlide $ \(s, _) -> (s + 10, 0)
-    SkipBackward      -> pure $ goToSlide $ \(s, _) -> (s - 10, 0)
-    First             -> pure $ goToSlide $ \_ -> (0, 0)
-    Last              -> pure $ goToSlide $ \_ -> (numSlides presentation, 0)
-    Seek n            -> pure $ goToSlide $ \_ -> (n - 1, 0)
-    Reload            -> reloadPresentation
-    UpdateEvalBlock u -> pure $ UpdatedPresentation $ Eval.updateEvalBlock u presentation
-    UnknownCommand  _ -> pure $ UpdatedPresentation presentation
+    Exit             -> pure ExitedPresentation
+    Forward          -> pure $ goToSlide $ \(s, f) -> (s, f + 1)
+    Backward         -> pure $ goToSlide $ \(s, f) -> (s, f - 1)
+    SkipForward      -> pure $ goToSlide $ \(s, _) -> (s + 10, 0)
+    SkipBackward     -> pure $ goToSlide $ \(s, _) -> (s - 10, 0)
+    First            -> pure $ goToSlide $ \_ -> (0, 0)
+    Last             -> pure $ goToSlide $ \_ -> (numSlides presentation, 0)
+    Seek n           -> pure $ goToSlide $ \_ -> (n - 1, 0)
+    Reload           -> reloadPresentation
+    UpdateVar u      -> pure $ UpdatedPresentation $ Eval.updateVar u presentation
+    UnknownCommand _ -> pure $ UpdatedPresentation presentation
   where
     numSlides :: Presentation -> Int
     numSlides pres = length (pSlides pres)

lib/Patat/Presentation/Internal.hs

@@ -79,8 +79,7 @@ data Presentation = Presentation
     , pActiveFragment   :: !Index
     , pSyntaxMap        :: !Skylighting.SyntaxMap
     , pEvalBlocks       :: !Eval.EvalBlocks
-    -- TODO: these can be a bit more generic than just eval.
-    -- , pVars             :: !(HMS.HashMap Instruction.Var [Pandoc.Block])
+    , pVars             :: !(HMS.HashMap Instruction.Var [Pandoc.Block])
     }
 
 
@@ -155,9 +154,7 @@ activeFragment presentation = do
             Instruction.renderFragment resolve $
             Instruction.beforePause fidx instrs
   where
-    resolve var = case HMS.lookup var (pEvalBlocks presentation) of
-        Nothing -> []
-        Just eb -> Eval.evalBlockToBlocks eb
+    resolve var = fromMaybe [] $ HMS.lookup var (pVars presentation)
 
 
 --------------------------------------------------------------------------------

lib/Patat/Presentation/Read.hs

@@ -135,6 +135,7 @@ pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap
         !pActiveFragment = (0, 0)
         !pAuthor         = concat (Pandoc.docAuthors meta)
         !pEvalBlocks     = mempty
+        !pVars           = mempty
     pSlideSettings <- Seq.traverseWithIndex
         (\i ->
             first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) .