diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs index 460d583..b5cadc8 100644 --- a/lib/Patat/Eval.hs +++ b/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)) diff --git a/lib/Patat/Eval/Internal.hs b/lib/Patat/Eval/Internal.hs index ccb158b..926e163 100644 --- a/lib/Patat/Eval/Internal.hs +++ b/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 diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs index e219afc..b7bd9e1 100644 --- a/lib/Patat/Main.hs +++ b/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 diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs index aae8ff4..fb5e443 100644 --- a/lib/Patat/Presentation/Interactive.hs +++ b/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 } diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs index 7b87e9e..b249b0c 100644 --- a/lib/Patat/Presentation/Internal.hs +++ b/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]) } diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs index 5ec3482..1b2afdb 100644 --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -70,10 +70,9 @@ readPresentation filePath = runExceptT $ do Left e -> throwError $ "Could not parse document: " ++ show e Right x -> return x - eval <- liftIO $ Eval.newHandle pres <- ExceptT $ pure $ - pandocToPresentation filePath enc settings syntaxMap eval doc - liftIO $ Eval.eval pres + pandocToPresentation filePath enc settings syntaxMap doc + pure $ Eval.parseEvalBlocks pres where ext = takeExtension filePath @@ -124,10 +123,11 @@ readExtension (ExtensionList extensions) fileExt = case fileExt of -------------------------------------------------------------------------------- pandocToPresentation :: FilePath -> EncodingFallback -> PresentationSettings - -> Skylighting.SyntaxMap -> Eval.Handle -> Pandoc.Pandoc -> Either String Presentation -pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap pEval + -> Skylighting.SyntaxMap -> Pandoc.Pandoc -> Either String Presentation +pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap pandoc@(Pandoc.Pandoc meta _) = do - let !pTitle = case Pandoc.docTitle meta of + let !pVersion = 0 + !pTitle = case Pandoc.docTitle meta of [] -> [Pandoc.Str . T.pack . snd $ splitFileName pFilePath] title -> title !pSlides = pandocToSlides pSettings pandoc