From 6993867f53a403072ad0016311cdc065351e60b4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Oct 2024 20:03:48 +0200 Subject: [PATCH] WIP --- lib/Patat/Eval.hs | 22 +++---- lib/Patat/Eval/Internal.hs | 94 ++++++++++++++++++++++++++++++ lib/Patat/Presentation/Internal.hs | 4 +- lib/Patat/Presentation/Read.hs | 6 +- patat.cabal | 2 + 5 files changed, 112 insertions(+), 16 deletions(-) create mode 100644 lib/Patat/Eval/Internal.hs diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs index a923b38..29c059c 100644 --- 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 new file mode 100644 index 0000000..b39e978 --- /dev/null +++ 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 index 59270b4..5db0a5c 100644 --- 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 index c9f4063..62f0ddb 100644 --- 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 index e7c4371..ead884a 100644 --- 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