MVP

lib/Patat/Eval.hs

@@ -2,46 +2,43 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 module Patat.Eval
-    ( Handle
-    , newHandle
-    , eval  -- TODO: Rename
-    , startEval
+    ( parseEvalBlocks
 
     , UpdateEvalBlock
     , updateEvalBlock
-    , startEval2
+    , evalVar
+    , evalVars
+    , forceEval
     ) where
 
 
 --------------------------------------------------------------------------------
 import qualified Control.Concurrent.Async       as Async
-import           Control.Exception              (finally)
+import           Control.Exception              (IOException, catch, finally)
+import           Control.Monad                  (foldM, forever)
 import           Control.Monad.State            (StateT, evalStateT, state)
-import           Control.Monad.Trans            (liftIO)
-import           Control.Monad.Writer           (WriterT, runWriterT, tell)
+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 = do
-    (pres, evalBlocks) <- runWriterT $ evalStateT work zeroVarGen
-    pure pres
-        { pEval       = (pEval pres) {hBlocks = evalBlocks}
-        , pEvalBlocks = evalBlocks
-        }
+parseEvalBlocks :: Presentation -> Presentation
+parseEvalBlocks presentation =
+    let (pres, evalBlocks) = runWriter $ evalStateT work zeroVarGen in
+    pres {pEvalBlocks = evalBlocks}
   where
     work = case psEval (pSettings presentation) of
         Nothing -> pure presentation
@@ -60,7 +57,7 @@ lookupSettings classes settings = do
 --------------------------------------------------------------------------------
 -- | Monad used for identifying and extracting the evaluation blocks from a
 -- presentation.
-type ExtractEvalM a = StateT VarGen (WriterT (HMS.HashMap Var EvalBlock) IO) a
+type ExtractEvalM a = StateT VarGen (Writer (HMS.HashMap Var EvalBlock)) a
 
 
 --------------------------------------------------------------------------------
@@ -95,27 +92,15 @@ 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
-        out <- liftIO $ 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]]
         pure $ case (evalFragment, evalReplace) of
-            (False, True) -> [Append blocks, AppendVar var]
-            (False, False) -> [Append (orig : blocks), AppendVar var]
+            (False, True) -> [AppendVar var]
+            (False, False) -> [Append [orig], AppendVar var]
             (True, True) ->
                 [ Append [orig], Pause
-                , Delete, Append blocks, AppendVar var
+                , Delete, AppendVar var
                 ]
             (True, False) ->
-                [Append [orig], Pause, Append blocks, AppendVar var]
+                [Append [orig], Pause, AppendVar var]
     | _ : _ : _ <- lookupSettings classes settings =
         let msg = "patat eval matched multiple settings for " <>
                 T.intercalate "," classes in
@@ -125,53 +110,25 @@ evalBlock _ block =
 
 
 --------------------------------------------------------------------------------
-data EvalResult = EvalResult
-    { erExitCode :: !ExitCode
-    , erStdout   :: !T.Text
-    , erStderr   :: !T.Text
-    } deriving (Show)
-
-
---------------------------------------------------------------------------------
-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
-            }
-
-    (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
-
-        erExitCode <- Async.wait exitCodeAsync
-        erStdout <- Async.wait outAsync
-        erStderr <- Async.wait errAsync
-        pure $ EvalResult {..}
-
-
---------------------------------------------------------------------------------
--- TODO: add version
-data UpdateEvalBlock = UpdateEvalBlock Var T.Text
+data UpdateEvalBlock = UpdateEvalBlock Int Var T.Text
     deriving (Eq, Show)
 
 
 --------------------------------------------------------------------------------
 updateEvalBlock :: UpdateEvalBlock -> Presentation -> Presentation
-updateEvalBlock (UpdateEvalBlock var out) pres = pres
-    { pEvalBlocks = HMS.adjust adjust var $ pEvalBlocks pres
-    }
+updateEvalBlock (UpdateEvalBlock version var out) pres
+    | version /= pVersion pres = pres
+    | otherwise                = pres
+        { pEvalBlocks = HMS.adjust adjust var $ pEvalBlocks pres
+        }
   where
-    adjust b = b {ebOutput = out}
+    addLine x = if T.null x then out else x <> "\n" <> out
+    adjust b = b {ebOutput = addLine (ebOutput b)}
 
 
 --------------------------------------------------------------------------------
-startEval2 :: Var -> (UpdateEvalBlock -> IO ()) -> Presentation -> IO Presentation
-startEval2 var writeOutput presentation = case HMS.lookup var evalBlocks of
+evalVar :: Var -> (UpdateEvalBlock -> 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
@@ -184,20 +141,54 @@ startEval2 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 (T.hGetContents hOut) $ \outAsync ->
-            Async.withAsync (T.hGetContents hErr) $ \errAsync ->
+            Async.withAsync (getLines hOut) $ \outAsync ->
+            Async.withAsync (getLines hErr) $ \errAsync ->
             Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do
             erExitCode <- Async.wait exitCodeAsync
-            erStdout <- Async.wait outAsync
-            erStderr <- Async.wait errAsync
-            let out = case erExitCode of
-                    ExitSuccess -> erStdout
-                    ExitFailure i ->
-                        evalCommand <> ": exit code " <> T.pack (show i) <> "\n" <>
-                        erStderr
-            writeOutput $ UpdateEvalBlock var out
+            _ <- Async.wait outAsync
+            _ <- Async.wait errAsync
+            case erExitCode of
+                ExitSuccess -> pure ()
+                ExitFailure i -> writeOutput $ mkUpdateEvalBlock $
+                    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
+evalVars vars update presentation =
+    foldM (\p var -> evalVar var update p) presentation vars
+
+
+--------------------------------------------------------------------------------
+forceEval :: Presentation -> IO Presentation
+forceEval 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 -> updateEvalBlock u p) pres1 l)
+
+    foldM forceEvalVar pres (HMS.keys (pEvalBlocks pres))

lib/Patat/Eval/Internal.hs

@@ -4,27 +4,15 @@ module Patat.Eval.Internal
     ( EvalBlocks
     , EvalBlock (..)
     , evalBlockToBlocks
-
-    , EvalState (..)
-    , Handle (..)
-    , newHandle
-    , startEval
     ) where
 
 
 --------------------------------------------------------------------------------
 import qualified Control.Concurrent.Async       as Async
-import           Control.Exception              (finally)
-import           Control.Monad                  (when)
 import qualified Data.HashMap.Strict            as HMS
-import qualified Data.IORef                     as IORef
 import qualified Data.Text                      as T
-import qualified Data.Text.IO                   as T
 import           Patat.Presentation.Instruction
 import           Patat.Presentation.Settings
-import           System.Exit                    (ExitCode (..))
-import qualified System.IO                      as IO
-import qualified System.Process                 as Process
 import qualified Text.Pandoc                    as Pandoc
 
 
@@ -51,63 +39,3 @@ evalBlockToBlocks EvalBlock {..} = case evalContainer ebSettings of
     EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt ebOutput]]
   where
     fmt = "eval"
-
-
---------------------------------------------------------------------------------
-data EvalState
-    = Starting
-    | Running (Async.Async ())
-
-
---------------------------------------------------------------------------------
-data Handle = Handle
-    { hBlocks :: HMS.HashMap Var EvalBlock
-    , hState  :: IORef.IORef (HMS.HashMap Var EvalState)
-    , hOutput :: IORef.IORef (HMS.HashMap Var T.Text)
-    }
-
-
---------------------------------------------------------------------------------
-newHandle :: IO Handle
-newHandle = Handle HMS.empty <$> IORef.newIORef mempty <*> IORef.newIORef mempty
-
-
---------------------------------------------------------------------------------
-startEval :: Handle -> Var -> IO () -> IO ()
-startEval Handle {..} var notify = case HMS.lookup var hBlocks of
-    Nothing -> pure ()
-    Just EvalBlock {..} -> do
-        let EvalSettings {..} = ebSettings
-        needStart <- IORef.atomicModifyIORef' hState $ \m ->
-            case HMS.lookup var m of
-                Nothing          -> (HMS.insert var Starting m, True)
-                Just Starting    -> (m, False)
-                Just (Running _) -> (m, False)
-        when needStart $ do
-            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 (T.hGetContents hOut) $ \outAsync ->
-                Async.withAsync (T.hGetContents hErr) $ \errAsync ->
-                Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do
-                erExitCode <- Async.wait exitCodeAsync
-                erStdout <- Async.wait outAsync
-                erStderr <- Async.wait errAsync
-                let out = case erExitCode of
-                        ExitSuccess -> erStdout
-                        ExitFailure i ->
-                            evalCommand <> ": exit code " <> T.pack (show i) <> "\n" <>
-                            erStderr
-                writeOutput out
-            IORef.atomicModifyIORef' hState $ \m ->
-                (HMS.insert var (Running async) m, ())
-  where
-    writeOutput out = do
-        IORef.atomicModifyIORef' hOutput $ \m ->
-            (HMS.alter (\_ -> Just out) var m, ())
-        notify

lib/Patat/Main.hs

@@ -13,8 +13,7 @@ import qualified Control.Concurrent.Async         as Async
 import           Control.Concurrent.Chan.Extended (Chan)
 import qualified Control.Concurrent.Chan.Extended as Chan
 import           Control.Exception                (bracket)
-import           Control.Monad                    (foldM, forever, unless, void,
-                                                   when)
+import           Control.Monad                    (forever, unless, void, when)
 import qualified Data.Aeson.Extended              as A
 import           Data.Foldable                    (for_)
 import           Data.Functor                     (($>))
@@ -169,8 +168,8 @@ main = do
     unless (oForce options) assertAnsiFeatures
 
     if oDump options then
-        EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $
-        dumpPresentation pres
+        EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ do
+        Eval.forceEval pres >>= dumpPresentation
     else
         -- (Maybe) initialize images backend.
         withMaybeHandle Images.withHandle (psImages settings) $ \images ->
@@ -212,11 +211,10 @@ loop app@App {..} = do
         (activeSpeakerNotes aPresentation)
 
     -- Start necessary eval blocks
-    presentation <- foldM
-        (\presentation var ->
-            Eval.startEval2 var (\u -> Chan.writeChan aCommandChan (PresentationCommand $ UpdateEvalBlock u)) presentation)
-        aPresentation
+    presentation <- Eval.evalVars
         (activeVars aPresentation)
+        (Chan.writeChan aCommandChan . PresentationCommand . UpdateEvalBlock)
+        aPresentation
 
     size <- getPresentationSize presentation
     Ansi.clearScreen

lib/Patat/Presentation/Interactive.hs

@@ -140,5 +140,6 @@ updatePresentation cmd presentation = case cmd of
         return $ case errOrPres of
             Left  err  -> ErroredPresentation err
             Right pres -> UpdatedPresentation $ pres
-                { pActiveFragment = clip (pActiveFragment presentation) pres
+                { pVersion        = pVersion presentation + 1
+                , pActiveFragment = clip (pActiveFragment presentation) pres
                 }

lib/Patat/Presentation/Internal.hs

@@ -67,6 +67,7 @@ type Breadcrumbs = [(Int, [Pandoc.Inline])]
 --------------------------------------------------------------------------------
 data Presentation = Presentation
     { pFilePath         :: !FilePath
+    , pVersion          :: !Int
     , pEncodingFallback :: !EncodingFallback
     , pTitle            :: ![Pandoc.Inline]
     , pAuthor           :: ![Pandoc.Inline]
@@ -77,8 +78,9 @@ data Presentation = Presentation
     , pTransitionGens   :: !(Seq (Maybe TransitionGen))  -- One for each slide.
     , pActiveFragment   :: !Index
     , pSyntaxMap        :: !Skylighting.SyntaxMap
-    , pEval             :: !Eval.Handle
     , pEvalBlocks       :: !Eval.EvalBlocks
+    -- TODO: these can be a bit more generic than just eval.
+    -- , pVars             :: !(HMS.HashMap Instruction.Var [Pandoc.Block])
     }