WIP

lib/Patat/Eval.hs

@@ -3,8 +3,13 @@
 {-# LANGUAGE RecordWildCards   #-}
 module Patat.Eval
     ( Handle
-    , emptyHandle
-    , eval
+    , newHandle
+    , eval  -- TODO: Rename
+    , startEval
+
+    , UpdateEvalBlock
+    , updateEvalBlock
+    , startEval2
     ) where
 
 
@@ -15,7 +20,6 @@ import           Control.Monad.State            (StateT, evalStateT, state)
 import           Control.Monad.Trans            (liftIO)
 import           Control.Monad.Writer           (WriterT, runWriterT, tell)
 import qualified Data.HashMap.Strict            as HMS
-import qualified Data.IORef                     as IORef
 import           Data.Maybe                     (maybeToList)
 import qualified Data.Text                      as T
 import qualified Data.Text.IO                   as T
@@ -34,8 +38,10 @@ import qualified Text.Pandoc.Definition         as Pandoc
 eval :: Presentation -> IO Presentation
 eval presentation = do
     (pres, evalBlocks) <- runWriterT $ evalStateT work zeroVarGen
-    outputs <- traverse (\_ -> IORef.newIORef mempty) evalBlocks
-    pure pres {pEval = Handle evalBlocks outputs}
+    pure pres
+        { pEval       = (pEval pres) {hBlocks = evalBlocks}
+        , pEvalBlocks = evalBlocks
+        }
   where
     work = case psEval (pSettings presentation) of
         Nothing -> pure presentation
@@ -88,8 +94,7 @@ evalBlock
 evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt)
     | [s@EvalSettings {..}] <- lookupSettings classes settings = do
         var <- state freshVar
-        running <- liftIO $ IORef.newIORef NotRunning
-        tell $ HMS.singleton var $ EvalBlock s txt running
+        tell $ HMS.singleton var $ EvalBlock s txt Nothing mempty
         out <- liftIO $ unsafeInterleaveIO $ do
             EvalResult {..} <- evalCode s txt
             pure $ case erExitCode of
@@ -103,14 +108,14 @@ evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt)
                 EvalContainerNone   -> [Pandoc.RawBlock fmt out]
                 EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt out]]
         pure $ case (evalFragment, evalReplace) of
-            (False, True) -> [Append blocks]
-            (False, False) -> [Append (orig : blocks)]
+            (False, True) -> [Append blocks, AppendVar var]
+            (False, False) -> [Append (orig : blocks), AppendVar var]
             (True, True) ->
                 [ Append [orig], Pause
-                , Delete, Append blocks
+                , Delete, Append blocks, AppendVar var
                 ]
             (True, False) ->
-                [Append [orig], Pause, Append blocks]
+                [Append [orig], Pause, Append blocks, AppendVar var]
     | _ : _ : _ <- lookupSettings classes settings =
         let msg = "patat eval matched multiple settings for " <>
                 T.intercalate "," classes in
@@ -147,3 +152,55 @@ evalCode EvalSettings {..} input = do
         erStdout <- Async.wait outAsync
         erStderr <- Async.wait errAsync
         pure $ EvalResult {..}
+
+
+--------------------------------------------------------------------------------
+-- TODO: add version
+data UpdateEvalBlock = UpdateEvalBlock Var T.Text
+    deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
+updateEvalBlock :: UpdateEvalBlock -> Presentation -> Presentation
+updateEvalBlock (UpdateEvalBlock var out) pres = pres
+    { pEvalBlocks = HMS.adjust adjust var $ pEvalBlocks pres
+    }
+  where
+    adjust b = b {ebOutput = out}
+
+
+--------------------------------------------------------------------------------
+startEval2 :: Var -> (UpdateEvalBlock -> IO ()) -> Presentation -> IO Presentation
+startEval2 var writeOutput presentation = case HMS.lookup var evalBlocks of
+    Nothing -> pure presentation
+    Just EvalBlock {..} | Just _ <- ebAsync -> pure presentation
+    Just eb@EvalBlock {..} -> do
+        appendFile "log.txt" $ "starting eval for var " ++ show var ++ "\n"
+        let EvalSettings {..} = ebSettings
+        let proc = (Process.shell $ T.unpack evalCommand)
+                { Process.std_in  = Process.CreatePipe
+                , Process.std_out = Process.CreatePipe
+                , Process.std_err = Process.CreatePipe
+                }
+        appendFile "log.txt" $ "Creating process\n"
+        (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
+            appendFile "log.txt" $ "OUT: " ++ show out ++ "\n"
+            writeOutput $ UpdateEvalBlock var out
+        pure presentation
+            { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks
+            }
+  where
+    evalBlocks = pEvalBlocks presentation

lib/Patat/Eval/Internal.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 module Patat.Eval.Internal
-    ( EvalBlock (..)
+    ( EvalBlocks
+    , EvalBlock (..)
     , EvalState (..)
     , Handle (..)
-    , emptyHandle
+    , newHandle
     , startEval
     ) where
 
@@ -14,8 +15,7 @@ import qualified Control.Concurrent.Async       as Async
 import           Control.Exception              (finally)
 import           Control.Monad                  (when)
 import qualified Data.HashMap.Strict            as HMS
-import           Data.IORef                     (IORef, atomicModifyIORef',
-                                                 writeIORef)
+import qualified Data.IORef                     as IORef
 import qualified Data.Text                      as T
 import qualified Data.Text.IO                   as T
 import           Patat.Presentation.Instruction
@@ -25,32 +25,37 @@ import qualified System.IO                      as IO
 import qualified System.Process                 as Process
 
 
+--------------------------------------------------------------------------------
+type EvalBlocks = HMS.HashMap Var EvalBlock
+
+
 --------------------------------------------------------------------------------
 -- | Block that needs to be evaluated.
 data EvalBlock = EvalBlock
-    { ebSettings :: EvalSettings
-    , ebInput    :: T.Text
-    , ebState    :: IORef EvalState
+    { ebSettings :: !EvalSettings
+    , ebInput    :: !T.Text
+    , ebAsync    :: !(Maybe (Async.Async ()))
+    , ebOutput   :: !T.Text
     }
 
 
 --------------------------------------------------------------------------------
 data EvalState
-    = NotRunning
-    | Starting
+    = Starting
     | Running (Async.Async ())
 
 
 --------------------------------------------------------------------------------
 data Handle = Handle
     { hBlocks :: HMS.HashMap Var EvalBlock
-    , hOutput :: HMS.HashMap Var (IORef T.Text)
+    , hState  :: IORef.IORef (HMS.HashMap Var EvalState)
+    , hOutput :: IORef.IORef (HMS.HashMap Var T.Text)
     }
 
 
 --------------------------------------------------------------------------------
-emptyHandle :: Handle
-emptyHandle = Handle HMS.empty HMS.empty
+newHandle :: IO Handle
+newHandle = Handle HMS.empty <$> IORef.newIORef mempty <*> IORef.newIORef mempty
 
 
 --------------------------------------------------------------------------------
@@ -59,11 +64,11 @@ startEval Handle {..} var notify = case HMS.lookup var hBlocks of
     Nothing -> pure ()
     Just EvalBlock {..} -> do
         let EvalSettings {..} = ebSettings
-        needStart <- atomicModifyIORef' ebState $ \mbRunning ->
-            case mbRunning of
-                NotRunning -> (Starting, True)
-                Starting   -> (Starting, False)
-                Running r  -> (Running r, False)
+        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
@@ -85,10 +90,10 @@ startEval Handle {..} var notify = case HMS.lookup var hBlocks of
                             evalCommand <> ": exit code " <> T.pack (show i) <> "\n" <>
                             erStderr
                 writeOutput out
-            writeIORef ebState $ Running async
+            IORef.atomicModifyIORef' hState $ \m ->
+                (HMS.insert var (Running async) m, ())
   where
-    writeOutput out = case HMS.lookup var hOutput of
-        Nothing  -> pure ()
-        Just ref -> do
-            atomicModifyIORef' ref $ \_ -> (out, ())
-            notify
+    writeOutput out = do
+        IORef.atomicModifyIORef' hOutput $ \m ->
+            (HMS.alter (\_ -> Just out) var m, ())
+        notify

lib/Patat/Main.hs

@@ -13,7 +13,8 @@ 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                    (forever, unless, void, when)
+import           Control.Monad                    (foldM, forever, unless, void,
+                                                   when)
 import qualified Data.Aeson.Extended              as A
 import           Data.Foldable                    (for_)
 import           Data.Functor                     (($>))
@@ -24,6 +25,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
@@ -209,15 +211,24 @@ loop app@App {..} = do
         (pEncodingFallback aPresentation)
         (activeSpeakerNotes aPresentation)
 
-    size <- getPresentationSize aPresentation
+    -- Start necessary eval blocks
+    appendFile "log.txt" "lol test\n"
+    presentation <- foldM
+        (\presentation var -> do
+            appendFile "log.txt" ("starting var: " ++ show var ++ "\n")
+            Eval.startEval2 var (\u -> Chan.writeChan aCommandChan (PresentationCommand $ UpdateEvalBlock u)) presentation)
+        aPresentation
+        (activeVars 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 +245,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 +262,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

lib/Patat/Presentation.hs

@@ -6,6 +6,7 @@ module Patat.Presentation
     , readPresentation
 
     , activeSpeakerNotes
+    , activeVars
 
     , Size
     , getPresentationSize

lib/Patat/Presentation/Display.hs

@@ -103,11 +103,11 @@ displayPresentation :: Size -> Presentation -> Display
 displayPresentation size pres@Presentation {..} =
      case activeFragment pres of
         Nothing -> DisplayDoc $ displayWithBorders size pres mempty
-        Just (ActiveContent fragment _)
+        Just (ActiveContent fragment)
                 | Just _ <- psImages pSettings
                 , Just image <- onlyImage fragment ->
             DisplayImage $ T.unpack image
-        Just (ActiveContent fragment _) -> DisplayDoc $
+        Just (ActiveContent fragment) -> DisplayDoc $
             displayWithBorders size pres $ \theme ->
                 prettyFragment theme fragment
         Just (ActiveTitle block) -> DisplayDoc $
@@ -161,7 +161,8 @@ dumpPresentation pres@Presentation {..} =
     dumpFragment :: Index -> [PP.Doc]
     dumpFragment idx =
         case displayPresentation (getSize idx) pres {pActiveFragment = idx} of
-            DisplayDoc doc        -> [doc]
+            -- TODO: wait until everything is evaluated before dumping.
+            DisplayDoc   doc      -> [doc]
             DisplayImage filepath -> [PP.string $ "{image: " ++ filepath ++ "}"]
 
     getSize :: Index -> Size
@@ -187,7 +188,7 @@ prettyFragment ds (Fragment blocks) = vertical $
         mconcat (replicate top PP.hardline) <> doc0
       where
         top = case mTop of
-            Auto -> let (r, _) = PP.dimensions doc0 in (rows - r) `div` 2
+            Auto      -> let (r, _) = PP.dimensions doc0 in (rows - r) `div` 2
             NotAuto x -> x
 
     horizontal = horizontalIndent . horizontalWrap

lib/Patat/Presentation/Instruction.hs

@@ -20,11 +20,13 @@ module Patat.Presentation.Instruction
     , numFragments
     , variables
 
+    , ResolveVar
     , Fragment (..)
     , renderFragment
     ) where
 
 import           Data.Hashable (Hashable)
+import qualified Data.HashSet as HS
 import           Data.List     (foldl')
 import qualified Text.Pandoc   as Pandoc
 
@@ -90,14 +92,17 @@ beforePause n = Instructions . go 0 . unInstructions
     go i (Pause : t) = if i >= n then [] else go (i + 1) t
     go i (h     : t) = h : go i t
 
-variables :: Instructions a -> [Var]
-variables (Instructions []               ) = []
-variables (Instructions (AppendVar v : t)) = v : variables (Instructions t)
-variables (Instructions (_           : t)) = variables (Instructions t)
+variables :: Instructions a -> HS.HashSet Var
+variables (Instructions []               )  = mempty
+variables (Instructions (AppendVar v : t))  = HS.insert v (variables (Instructions t))
+variables (Instructions (ModifyLast i : t)) = variables (Instructions t) <> variables (Instructions [i])
+variables (Instructions (_           : t))  = variables (Instructions t)
 
 numFragments :: Instructions a -> Int
 numFragments = succ . numPauses
 
+type ResolveVar = Var -> [Pandoc.Block]
+
 newtype Fragment = Fragment [Pandoc.Block] deriving (Show)
 
 renderFragment
@@ -106,7 +111,7 @@ renderFragment resolve = \instrs -> Fragment $ foldl'
     (\acc instr -> goBlocks resolve instr acc) [] (unInstructions instrs)
 
 goBlocks
-    :: (Var -> [Pandoc.Block]) -> Instruction Pandoc.Block -> [Pandoc.Block]
+    :: ResolveVar -> Instruction Pandoc.Block -> [Pandoc.Block]
     -> [Pandoc.Block]
 goBlocks _ Pause xs = xs
 goBlocks _ (Append ys) xs = xs ++ ys
@@ -117,7 +122,7 @@ goBlocks resolve (ModifyLast f) xs
     | otherwise = modifyLast (goBlock resolve f) xs
 
 goBlock
-    :: (Var -> [Pandoc.Block]) -> Instruction Pandoc.Block -> Pandoc.Block
+    :: ResolveVar -> Instruction Pandoc.Block -> Pandoc.Block
     -> Pandoc.Block
 goBlock _ Pause x = x
 goBlock _ (Append ys) block = case block of