WIP

jaspervdj · Oct 23, 2024 · 6993867 · 6993867
1 parent 505635d
commit 6993867
Show file tree

Hide file tree

Showing 5 changed files with 112 additions and 16 deletions.
diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs
@@ -2,20 +2,24 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 module Patat.Eval
-    ( eval
+    ( Handle
+    , emptyHandle
+    , eval
     ) where
 
 
 --------------------------------------------------------------------------------
 import qualified Control.Concurrent.Async       as Async
 import           Control.Exception              (finally)
-import           Control.Monad.State            (StateT, runStateT, state)
+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
+import           Patat.Eval.Internal
 import           Patat.Presentation.Instruction
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Settings
@@ -29,9 +33,9 @@ import qualified Text.Pandoc.Definition         as Pandoc
 --------------------------------------------------------------------------------
 eval :: Presentation -> IO Presentation
 eval presentation = do
-    ((pres, varGen), evalBlocks) <- runWriterT $
-        runStateT work (pVarGen presentation)
-    pure pres {pVarGen = varGen}
+    (pres, evalBlocks) <- runWriterT $ evalStateT work zeroVarGen
+    outputs <- traverse (\_ -> IORef.newIORef mempty) evalBlocks
+    pure pres {pEval = Handle evalBlocks outputs}
   where
     work = case psEval (pSettings presentation) of
         Nothing -> pure presentation
@@ -47,11 +51,6 @@ lookupSettings classes settings = do
     maybeToList $ HMS.lookup c settings
 
 
---------------------------------------------------------------------------------
--- | Block that needs to be evaluated.
-data EvalBlock = EvalBlock EvalSettings T.Text
-
-
 --------------------------------------------------------------------------------
 -- | Monad used for identifying and extracting the evaluation blocks from a
 -- presentation.
@@ -89,7 +88,8 @@ evalBlock
 evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt)
     | [s@EvalSettings {..}] <- lookupSettings classes settings = do
         var <- state freshVar
-        tell $ HMS.singleton var $ EvalBlock s txt
+        running <- liftIO $ IORef.newIORef NotRunning
+        tell $ HMS.singleton var $ EvalBlock s txt running
         out <- liftIO $ unsafeInterleaveIO $ do
             EvalResult {..} <- evalCode s txt
             pure $ case erExitCode of

diff --git a/lib/Patat/Eval/Internal.hs b/lib/Patat/Eval/Internal.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+module Patat.Eval.Internal
+    ( EvalBlock (..)
+    , EvalState (..)
+    , Handle (..)
+    , emptyHandle
+    , 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           Data.IORef                     (IORef, atomicModifyIORef',
+                                                 writeIORef)
+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
+
+
+--------------------------------------------------------------------------------
+-- | Block that needs to be evaluated.
+data EvalBlock = EvalBlock
+    { ebSettings :: EvalSettings
+    , ebInput    :: T.Text
+    , ebState    :: IORef EvalState
+    }
+
+
+--------------------------------------------------------------------------------
+data EvalState
+    = NotRunning
+    | Starting
+    | Running (Async.Async ())
+
+
+--------------------------------------------------------------------------------
+data Handle = Handle
+    { hBlocks :: HMS.HashMap Var EvalBlock
+    , hOutput :: HMS.HashMap Var (IORef T.Text)
+    }
+
+
+--------------------------------------------------------------------------------
+emptyHandle :: Handle
+emptyHandle = Handle HMS.empty HMS.empty
+
+
+--------------------------------------------------------------------------------
+startEval :: Handle -> Var -> IO () -> IO ()
+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)
+        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
+            writeIORef ebState $ Running async
+  where
+    writeOutput out = case HMS.lookup var hOutput of
+        Nothing  -> pure ()
+        Just ref -> do
+            atomicModifyIORef' ref $ \_ -> (out, ())
+            notify
diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs
@@ -46,6 +46,7 @@ import           Data.Maybe                     (fromMaybe)
 import           Data.Sequence.Extended         (Seq)
 import qualified Data.Sequence.Extended         as Seq
 import           Patat.EncodingFallback         (EncodingFallback)
+import qualified Patat.Eval.Internal            as Eval
 import qualified Patat.Presentation.Comments    as Comments
 import qualified Patat.Presentation.Instruction as Instruction
 import           Patat.Presentation.Settings
@@ -73,8 +74,7 @@ data Presentation = Presentation
     , pTransitionGens   :: !(Seq (Maybe TransitionGen))  -- One for each slide.
     , pActiveFragment   :: !Index
     , pSyntaxMap        :: !Skylighting.SyntaxMap
-    -- | Used to generate new variables inside the presentation.
-    , pVarGen           :: Instruction.VarGen
+    , pEval             :: !Eval.Handle
     }
 
 

diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs
@@ -28,7 +28,7 @@ import           Data.Traversable               (for)
 import qualified Data.Yaml                      as Yaml
 import           Patat.EncodingFallback         (EncodingFallback)
 import qualified Patat.EncodingFallback         as EncodingFallback
-import           Patat.Eval                     (eval)
+import qualified Patat.Eval                     as Eval
 import qualified Patat.Presentation.Comments    as Comments
 import           Patat.Presentation.Fragment
 import qualified Patat.Presentation.Instruction as Instruction
@@ -72,7 +72,7 @@ readPresentation filePath = runExceptT $ do
 
     pres <- ExceptT $ pure $
         pandocToPresentation filePath enc settings syntaxMap doc
-    liftIO $ eval pres
+    liftIO $ Eval.eval pres
   where
     ext = takeExtension filePath
 
@@ -133,7 +133,7 @@ pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap
         !pBreadcrumbs    = collectBreadcrumbs pSlides
         !pActiveFragment = (0, 0)
         !pAuthor         = concat (Pandoc.docAuthors meta)
-        !pVarGen         = Instruction.zeroVarGen
+        !pEval           = Eval.emptyHandle
     pSlideSettings <- Seq.traverseWithIndex
         (\i ->
             first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) .

diff --git a/patat.cabal b/patat.cabal
@@ -43,6 +43,7 @@ Library
     containers           >= 0.5  && < 0.7,
     directory            >= 1.2  && < 1.4,
     filepath             >= 1.4  && < 1.6,
+    hashable             >= 1.4  && < 1.5,
     mtl                  >= 2.2  && < 2.4,
     optparse-applicative >= 0.16 && < 0.19,
     pandoc               >= 3.1  && < 3.3,
@@ -71,6 +72,7 @@ Library
     Patat.Cleanup
     Patat.EncodingFallback
     Patat.Eval
+    Patat.Eval.Internal
     Patat.Images
     Patat.Images.Internal
     Patat.Images.ITerm2