diff --git a/CHANGELOG.md b/CHANGELOG.md index 3938abc..c1c65b5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ # Changelog +## 0.13.0.0 (unreleased) + + * Incrementally display output of `eval` commands (#132) + + Rather than waiting for the process to complete and then displaying its + output, `patat` now fetches the `stdout` and `stderr` as it becomes + available and refreshes the display. + + This means that by default, **stderr is now displayed as well**. + To disable displaying `stderr`, you can add `stderr: false` to the eval + configuration, e.g.: + + ```yaml + patat: + eval: + bash: + command: bash + stderr: false + ``` + ## 0.12.0.1 (2024-09-28) * Fix width of code blocks when using wide characters (#171) diff --git a/README.md b/README.md index 88ff090..f608525 100644 --- a/README.md +++ b/README.md @@ -720,7 +720,7 @@ attribute on a code block matches the evaluator, it will be used. code of presentations downloaded from the internet before running them if they contain `eval` settings. -Aside from the command, there are three more options: +Aside from the command, there are four more options: - `fragment`: Introduce a pause (see [fragments](#fragmented-slides)) in between showing the original code block and the output. Defaults to `true`. @@ -732,6 +732,7 @@ Aside from the command, there are three more options: * `code`: the default setting. * `none`: no formatting applied. * `inline`: no formatting applied and no trailing newline. + - `stderr`: Include output from standard error. Defaults to `true`. - `wrap`: this is a deprecated name for `container`, used in version 0.11 and earlier. diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs index 5bc6f81..c08111b 100644 --- a/lib/Patat/Eval.hs +++ b/lib/Patat/Eval.hs @@ -2,34 +2,48 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Patat.Eval - ( eval + ( parseEvalBlocks + + , evalVar + , evalActiveVars + , evalAllVars ) where -------------------------------------------------------------------------------- import qualified Control.Concurrent.Async as Async -import Control.Exception (finally) +import Control.Exception (IOException, catch, finally) +import Control.Monad (foldM, when) +import Control.Monad.State (StateT, runStateT, state) +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 = case psEval (pSettings presentation) of - Nothing -> pure presentation - Just settings -> do - slides <- traverse (evalSlide settings) (pSlides presentation) - pure presentation {pSlides = slides} +parseEvalBlocks :: Presentation -> Presentation +parseEvalBlocks presentation = + let ((pres, varGen), evalBlocks) = runWriter $ + runStateT work (pVarGen presentation) in + pres {pEvalBlocks = evalBlocks, pVarGen = varGen} + where + work = case psEval (pSettings presentation) of + Nothing -> pure presentation + Just settings -> do + slides <- traverse (evalSlide settings) (pSlides presentation) + pure presentation {pSlides = slides} -------------------------------------------------------------------------------- @@ -40,7 +54,13 @@ lookupSettings classes settings = do -------------------------------------------------------------------------------- -evalSlide :: EvalSettingsMap -> Slide -> IO Slide +-- | Monad used for identifying and extracting the evaluation blocks from a +-- presentation. +type ExtractEvalM a = StateT VarGen (Writer (HMS.HashMap Var EvalBlock)) a + + +-------------------------------------------------------------------------------- +evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide evalSlide settings slide = case slideContent slide of TitleSlide _ _ -> pure slide ContentSlide instrs0 -> do @@ -51,40 +71,35 @@ evalSlide settings slide = case slideContent slide of -------------------------------------------------------------------------------- evalInstruction :: EvalSettingsMap -> Instruction Pandoc.Block - -> IO [Instruction Pandoc.Block] + -> ExtractEvalM [Instruction Pandoc.Block] evalInstruction settings instr = case instr of Pause -> pure [Pause] ModifyLast i -> map ModifyLast <$> evalInstruction settings i Append [] -> pure [Append []] Append blocks -> concat <$> traverse (evalBlock settings) blocks + AppendVar v -> + -- Should not happen since we don't do recursive evaluation. + pure [AppendVar v] Delete -> pure [Delete] -------------------------------------------------------------------------------- -evalBlock :: EvalSettingsMap -> Pandoc.Block -> IO [Instruction Pandoc.Block] +evalBlock + :: EvalSettingsMap -> Pandoc.Block + -> ExtractEvalM [Instruction Pandoc.Block] evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt) | [s@EvalSettings {..}] <- lookupSettings classes settings = do - out <- 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]] + var <- state freshVar + tell $ HMS.singleton var $ EvalBlock s attr txt Nothing pure $ case (evalFragment, evalReplace) of - (False, True) -> [Append blocks] - (False, False) -> [Append (orig : blocks)] + (False, True) -> [AppendVar var] + (False, False) -> [Append [orig], AppendVar var] (True, True) -> [ Append [orig], Pause - , Delete, Append blocks + , Delete, AppendVar var ] (True, False) -> - [Append [orig], Pause, Append blocks] + [Append [orig], Pause, AppendVar var] | _ : _ : _ <- lookupSettings classes settings = let msg = "patat eval matched multiple settings for " <> T.intercalate "," classes in @@ -94,30 +109,78 @@ evalBlock _ block = -------------------------------------------------------------------------------- -data EvalResult = EvalResult - { erExitCode :: !ExitCode - , erStdout :: !T.Text - , erStderr :: !T.Text - } deriving (Show) +newAccum :: Monoid m => (m -> IO ()) -> IO (m -> IO ()) +newAccum f = do + ref <- IORef.newIORef mempty + pure $ \x -> + IORef.atomicModifyIORef' ref (\y -> let z = y <> x in (z, z)) >>= f -------------------------------------------------------------------------------- -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 +evalVar :: Var -> ([Pandoc.Block] -> 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 + let EvalSettings {..} = ebSettings + + writeChunk <- newAccum (writeOutput . renderEvalBlock eb) + let drainLines copy h = do + c <- catch (T.hGetChunk h) ((\_ -> pure "") :: IOException -> IO T.Text) + when (c /= "") $ do + when copy $ writeChunk c + drainLines copy h + + 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 (drainLines True hOut) $ \outAsync -> + Async.withAsync (drainLines evalStderr hErr) $ \errAsync -> + Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do + erExitCode <- Async.wait exitCodeAsync + _ <- Async.wait outAsync + _ <- Async.wait errAsync + case erExitCode of + ExitSuccess -> pure () + ExitFailure i -> writeChunk $ + evalCommand <> ": exit code " <> T.pack (show i) <> "\n" + pure presentation + { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks } + where + evalBlocks = pEvalBlocks presentation + - (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 +-------------------------------------------------------------------------------- +evalActiveVars + :: (Var -> [Pandoc.Block] -> IO ()) -> Presentation -> IO Presentation +evalActiveVars update presentation = foldM + (\p var -> evalVar var (update var) p) + presentation + (activeVars presentation) - erExitCode <- Async.wait exitCodeAsync - erStdout <- Async.wait outAsync - erStderr <- Async.wait errAsync - pure $ EvalResult {..} + +-------------------------------------------------------------------------------- +evalAllVars :: Presentation -> IO Presentation +evalAllVars 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 -> updateVar var 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 new file mode 100644 index 0000000..429376d --- /dev/null +++ b/lib/Patat/Eval/Internal.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Eval.Internal + ( EvalBlocks + , EvalBlock (..) + , renderEvalBlock + ) where + + +-------------------------------------------------------------------------------- +import qualified Control.Concurrent.Async as Async +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T +import Patat.Presentation.Instruction +import Patat.Presentation.Settings +import qualified Text.Pandoc as Pandoc + + +-------------------------------------------------------------------------------- +type EvalBlocks = HMS.HashMap Var EvalBlock + + +-------------------------------------------------------------------------------- +-- | Block that needs to be evaluated. +data EvalBlock = EvalBlock + { ebSettings :: !EvalSettings + , ebAttr :: !Pandoc.Attr + , ebInput :: !T.Text + , ebAsync :: !(Maybe (Async.Async ())) + } + + +-------------------------------------------------------------------------------- +renderEvalBlock :: EvalBlock -> T.Text -> [Pandoc.Block] +renderEvalBlock EvalBlock {..} out = case evalContainer ebSettings of + EvalContainerCode -> [Pandoc.CodeBlock ebAttr out] + EvalContainerNone -> [Pandoc.RawBlock fmt out] + EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt out]] + where + fmt = "eval" diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs index 54e985c..d858945 100644 --- a/lib/Patat/Main.hs +++ b/lib/Patat/Main.hs @@ -24,6 +24,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 @@ -160,15 +161,15 @@ main = do OA.parserFailure parserPrefs parserInfo (OA.ShowHelpText Nothing) mempty - errOrPres <- readPresentation filePath + errOrPres <- readPresentation zeroVarGen filePath pres <- either (errorAndExit . return) return errOrPres let settings = pSettings pres unless (oForce options) assertAnsiFeatures if oDump options then - EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ - dumpPresentation pres + EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ do + Eval.evalAllVars pres >>= dumpPresentation else -- (Maybe) initialize images backend. withMaybeHandle Images.withHandle (psImages settings) $ \images -> @@ -209,15 +210,20 @@ loop app@App {..} = do (pEncodingFallback aPresentation) (activeSpeakerNotes aPresentation) - size <- getPresentationSize aPresentation + -- Start necessary eval blocks + presentation <- Eval.evalActiveVars + (\v -> Chan.writeChan aCommandChan . PresentationCommand . UpdateVar v) + 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 +240,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 +257,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 diff --git a/lib/Patat/Presentation.hs b/lib/Patat/Presentation.hs index 7400f86..ae3a60f 100644 --- a/lib/Patat/Presentation.hs +++ b/lib/Patat/Presentation.hs @@ -2,10 +2,15 @@ module Patat.Presentation ( PresentationSettings (..) , defaultPresentationSettings + , VarGen + , Var + , zeroVarGen + , Presentation (..) , readPresentation , activeSpeakerNotes + , activeVars , Size , getPresentationSize @@ -22,6 +27,7 @@ module Patat.Presentation ) where import Patat.Presentation.Display +import Patat.Presentation.Instruction import Patat.Presentation.Interactive import Patat.Presentation.Internal import Patat.Presentation.Read diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs index 7ece483..8847d0d 100644 --- a/lib/Patat/Presentation/Display.hs +++ b/lib/Patat/Presentation/Display.hs @@ -161,7 +161,7 @@ dumpPresentation pres@Presentation {..} = dumpFragment :: Index -> [PP.Doc] dumpFragment idx = case displayPresentation (getSize idx) pres {pActiveFragment = idx} of - DisplayDoc doc -> [doc] + DisplayDoc doc -> [doc] DisplayImage filepath -> [PP.string $ "{image: " ++ filepath ++ "}"] getSize :: Index -> Size @@ -187,7 +187,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 diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs index 5575455..c13bab3 100644 --- a/lib/Patat/Presentation/Fragment.hs +++ b/lib/Patat/Presentation/Fragment.hs @@ -30,6 +30,7 @@ fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList fragmentInstruction Pause = [Pause] fragmentInstruction (Append []) = [Append []] fragmentInstruction (Append xs) = fragmentBlocks fs xs + fragmentInstruction (AppendVar v) = [AppendVar v] fragmentInstruction Delete = [Delete] fragmentInstruction (ModifyLast f) = map ModifyLast $ fragmentInstruction f diff --git a/lib/Patat/Presentation/Instruction.hs b/lib/Patat/Presentation/Instruction.hs index 3928e85..0c1f79a 100644 --- a/lib/Patat/Presentation/Instruction.hs +++ b/lib/Patat/Presentation/Instruction.hs @@ -4,21 +4,33 @@ -- -- We do this by modelling a slide as a list of instructions, that manipulate -- the contents on a slide in a (for now) very basic way. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Patat.Presentation.Instruction ( Instructions , fromList , toList + , Var + , VarGen + , zeroVarGen + , freshVar + , Instruction (..) + , beforePause , numFragments + , variables , Fragment (..) , renderFragment ) where -import qualified Text.Pandoc as Pandoc +import Data.Hashable (Hashable) +import qualified Data.HashSet as HS +import Data.List (foldl') +import qualified Text.Pandoc as Pandoc -newtype Instructions a = Instructions [Instruction a] deriving (Show) +newtype Instructions a = Instructions {unInstructions :: [Instruction a]} + deriving (Show) -- A smart constructor that guarantees some invariants: -- @@ -36,11 +48,26 @@ fromList = Instructions . go toList :: Instructions a -> [Instruction a] toList (Instructions xs) = xs +-- | A variable is like a placeholder in the instructions, something we don't +-- know yet, dynamic content. Currently this is only used for code evaluation. +newtype Var = Var Int deriving (Hashable, Eq, Ord, Show) + +-- | Used to generate fresh variables. +newtype VarGen = VarGen Int deriving (Show) + +zeroVarGen :: VarGen +zeroVarGen = VarGen 0 + +freshVar :: VarGen -> (Var, VarGen) +freshVar (VarGen x) = (Var x, VarGen (x + 1)) + data Instruction a -- Pause. = Pause -- Append items. | Append [a] + -- Append the content of a variable. + | AppendVar Var -- Remove the last item. | Delete -- Modify the last block with the provided instruction. @@ -48,52 +75,75 @@ data Instruction a deriving (Show) isPause :: Instruction a -> Bool -isPause Pause = True -isPause (Append _) = False -isPause Delete = False +isPause Pause = True +isPause (Append _) = False +isPause (AppendVar _) = False +isPause Delete = False isPause (ModifyLast i) = isPause i numPauses :: Instructions a -> Int numPauses (Instructions xs) = length $ filter isPause xs +beforePause :: Int -> Instructions a -> Instructions a +beforePause n = Instructions . go 0 . unInstructions + where + go _ [] = [] + go i (Pause : t) = if i >= n then [] else go (i + 1) t + go i (h : t) = h : go i 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 newtype Fragment = Fragment [Pandoc.Block] deriving (Show) -renderFragment :: Int -> Instructions Pandoc.Block -> Fragment -renderFragment = \n (Instructions instrs) -> Fragment $ go [] n instrs - where - go acc _ [] = acc - go acc n (Pause : instrs) = if n <= 0 then acc else go acc (n - 1) instrs - go acc n (instr : instrs) = go (goBlocks instr acc) n instrs - -goBlocks :: Instruction Pandoc.Block -> [Pandoc.Block] -> [Pandoc.Block] -goBlocks Pause xs = xs -goBlocks (Append ys) xs = xs ++ ys -goBlocks Delete xs = sinit xs -goBlocks (ModifyLast f) xs +renderFragment + :: (Var -> [Pandoc.Block]) -> Instructions Pandoc.Block -> Fragment +renderFragment resolve = \instrs -> Fragment $ foldl' + (\acc instr -> goBlocks resolve instr acc) [] (unInstructions instrs) + +goBlocks + :: (Var -> [Pandoc.Block]) -> Instruction Pandoc.Block -> [Pandoc.Block] + -> [Pandoc.Block] +goBlocks _ Pause xs = xs +goBlocks _ (Append ys) xs = xs ++ ys +goBlocks resolve (AppendVar v) xs = xs ++ resolve v +goBlocks _ Delete xs = sinit xs +goBlocks resolve (ModifyLast f) xs | null xs = xs -- Shouldn't happen unless instructions are malformed. - | otherwise = modifyLast (goBlock f) xs + | otherwise = modifyLast (goBlock resolve f) xs -goBlock :: Instruction Pandoc.Block -> Pandoc.Block -> Pandoc.Block -goBlock Pause x = x -goBlock (Append ys) block = case block of +goBlock + :: (Var -> [Pandoc.Block]) -> Instruction Pandoc.Block -> Pandoc.Block + -> Pandoc.Block +goBlock _ Pause x = x +goBlock _ (Append ys) block = case block of -- We can only append to a few specific block types for now. - Pandoc.BulletList xs -> Pandoc.BulletList $ xs ++ [ys] + Pandoc.BulletList xs -> Pandoc.BulletList $ xs ++ [ys] Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ xs ++ [ys] - _ -> block -goBlock Delete block = case block of + _ -> block +goBlock resolve (AppendVar v) block = case block of -- We can only append to a few specific block types for now. - Pandoc.BulletList xs -> Pandoc.BulletList $ sinit xs + Pandoc.BulletList xs -> Pandoc.BulletList $ xs ++ [resolve v] + Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ xs ++ [resolve v] + _ -> block +goBlock _ Delete block = case block of + -- We can only delete from a few specific block types for now. + Pandoc.BulletList xs -> Pandoc.BulletList $ sinit xs Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ sinit xs - _ -> block -goBlock (ModifyLast f) block = case block of + _ -> block +goBlock resolve (ModifyLast f) block = case block of -- We can only modify the last content of a few specific block types for -- now. - Pandoc.BulletList xs -> Pandoc.BulletList $ modifyLast (goBlocks f) xs - Pandoc.OrderedList attr xs -> - Pandoc.OrderedList attr $ modifyLast (goBlocks f) xs + Pandoc.BulletList xs -> Pandoc.BulletList $ + modifyLast (goBlocks resolve f) xs + Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ + modifyLast (goBlocks resolve f) xs _ -> block modifyLast :: (a -> a) -> [a] -> [a] diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs index bd3ba8a..2c95851 100644 --- a/lib/Patat/Presentation/Interactive.hs +++ b/lib/Patat/Presentation/Interactive.hs @@ -13,11 +13,13 @@ module Patat.Presentation.Interactive -------------------------------------------------------------------------------- -import Data.Char (isDigit) +import Data.Char (isDigit) +import Patat.Presentation.Instruction (Var) import Patat.Presentation.Internal import Patat.Presentation.Read -import qualified System.IO as IO -import Text.Read (readMaybe) +import qualified System.IO as IO +import qualified Text.Pandoc as Pandoc +import Text.Read (readMaybe) -------------------------------------------------------------------------------- @@ -31,6 +33,7 @@ data PresentationCommand | Last | Reload | Seek Int + | UpdateVar Var [Pandoc.Block] | UnknownCommand String deriving (Eq, Show) @@ -96,16 +99,17 @@ updatePresentation :: PresentationCommand -> Presentation -> IO UpdatedPresentation updatePresentation cmd presentation = case cmd of - Exit -> return ExitedPresentation - Forward -> return $ goToSlide $ \(s, f) -> (s, f + 1) - Backward -> return $ goToSlide $ \(s, f) -> (s, f - 1) - SkipForward -> return $ goToSlide $ \(s, _) -> (s + 10, 0) - SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0) - First -> return $ goToSlide $ \_ -> (0, 0) - Last -> return $ goToSlide $ \_ -> (numSlides presentation, 0) - Seek n -> return $ goToSlide $ \_ -> (n - 1, 0) + Exit -> pure ExitedPresentation + Forward -> pure $ goToSlide $ \(s, f) -> (s, f + 1) + Backward -> pure $ goToSlide $ \(s, f) -> (s, f - 1) + SkipForward -> pure $ goToSlide $ \(s, _) -> (s + 10, 0) + SkipBackward -> pure $ goToSlide $ \(s, _) -> (s - 10, 0) + First -> pure $ goToSlide $ \_ -> (0, 0) + Last -> pure $ goToSlide $ \_ -> (numSlides presentation, 0) + Seek n -> pure $ goToSlide $ \_ -> (n - 1, 0) Reload -> reloadPresentation - UnknownCommand _ -> return (UpdatedPresentation presentation) + UnknownCommand _ -> pure $ UpdatedPresentation presentation + UpdateVar v b -> pure $ UpdatedPresentation $ updateVar v b presentation where numSlides :: Presentation -> Int numSlides pres = length (pSlides pres) @@ -133,7 +137,7 @@ updatePresentation cmd presentation = case cmd of } reloadPresentation = do - errOrPres <- readPresentation (pFilePath presentation) + errOrPres <- readPresentation (pVarGen presentation) (pFilePath presentation) return $ case errOrPres of Left err -> ErroredPresentation err Right pres -> UpdatedPresentation $ pres diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs index 90f02ae..cf469f2 100644 --- a/lib/Patat/Presentation/Internal.hs +++ b/lib/Patat/Presentation/Internal.hs @@ -31,21 +31,27 @@ module Patat.Presentation.Internal , ActiveFragment (..) , activeFragment , activeSpeakerNotes + , activeVars , getSettings , activeSettings , Size , getPresentationSize + + , updateVar ) where -------------------------------------------------------------------------------- import qualified Data.Aeson.Extended as A +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashSet as HS 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,6 +79,9 @@ data Presentation = Presentation , pTransitionGens :: !(Seq (Maybe TransitionGen)) -- One for each slide. , pActiveFragment :: !Index , pSyntaxMap :: !Skylighting.SyntaxMap + , pEvalBlocks :: !Eval.EvalBlocks + , pVarGen :: !Instruction.VarGen + , pVars :: !(HMS.HashMap Instruction.Var [Pandoc.Block]) } @@ -144,7 +153,10 @@ activeFragment presentation = do TitleSlide lvl is -> ActiveTitle $ Pandoc.Header lvl Pandoc.nullAttr is ContentSlide instrs -> ActiveContent $ - Instruction.renderFragment fidx instrs + Instruction.renderFragment resolve $ + Instruction.beforePause fidx instrs + where + resolve var = fromMaybe [] $ HMS.lookup var (pVars presentation) -------------------------------------------------------------------------------- @@ -155,6 +167,17 @@ activeSpeakerNotes presentation = fromMaybe mempty $ do pure . Comments.cSpeakerNotes $ slideComment slide +-------------------------------------------------------------------------------- +activeVars :: Presentation -> HS.HashSet Instruction.Var +activeVars presentation = fromMaybe HS.empty $ do + let (sidx, fidx) = pActiveFragment presentation + slide <- getSlide sidx presentation + case slideContent slide of + TitleSlide _ _ -> Nothing + ContentSlide instrs -> pure $ Instruction.variables $ + Instruction.beforePause fidx instrs + + -------------------------------------------------------------------------------- getSettings :: Int -> Presentation -> PresentationSettings getSettings sidx pres = @@ -177,3 +200,8 @@ getPresentationSize pres = do pure $ Size {sRows = rows, sCols = cols} where settings = activeSettings pres + + +-------------------------------------------------------------------------------- +updateVar :: Instruction.Var -> [Pandoc.Block] -> Presentation -> Presentation +updateVar var blocks pres = pres {pVars = HMS.insert var blocks $ pVars pres} diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs index 8fe6b2b..bd0af50 100644 --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -28,10 +28,11 @@ 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 +import Patat.Presentation.Instruction (VarGen) import Patat.Presentation.Internal import Patat.Transition (parseTransitionSettings) import Prelude @@ -47,8 +48,8 @@ import qualified Text.Pandoc.Extended as Pandoc -------------------------------------------------------------------------------- -readPresentation :: FilePath -> IO (Either String Presentation) -readPresentation filePath = runExceptT $ do +readPresentation :: VarGen -> FilePath -> IO (Either String Presentation) +readPresentation varGen filePath = runExceptT $ do -- We need to read the settings first. (enc, src) <- liftIO $ EncodingFallback.readFile filePath homeSettings <- ExceptT readHomeSettings @@ -71,8 +72,8 @@ readPresentation filePath = runExceptT $ do Right x -> return x pres <- ExceptT $ pure $ - pandocToPresentation filePath enc settings syntaxMap doc - liftIO $ eval pres + pandocToPresentation varGen filePath enc settings syntaxMap doc + pure $ Eval.parseEvalBlocks pres where ext = takeExtension filePath @@ -122,9 +123,9 @@ readExtension (ExtensionList extensions) fileExt = case fileExt of -------------------------------------------------------------------------------- pandocToPresentation - :: FilePath -> EncodingFallback -> PresentationSettings + :: VarGen -> FilePath -> EncodingFallback -> PresentationSettings -> Skylighting.SyntaxMap -> Pandoc.Pandoc -> Either String Presentation -pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap +pandocToPresentation pVarGen pFilePath pEncodingFallback pSettings pSyntaxMap pandoc@(Pandoc.Pandoc meta _) = do let !pTitle = case Pandoc.docTitle meta of [] -> [Pandoc.Str . T.pack . snd $ splitFileName pFilePath] @@ -133,6 +134,8 @@ pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap !pBreadcrumbs = collectBreadcrumbs pSlides !pActiveFragment = (0, 0) !pAuthor = concat (Pandoc.docAuthors meta) + !pEvalBlocks = mempty + !pVars = mempty pSlideSettings <- Seq.traverseWithIndex (\i -> first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) . diff --git a/lib/Patat/Presentation/Settings.hs b/lib/Patat/Presentation/Settings.hs index 3799eb8..7ea13b7 100644 --- a/lib/Patat/Presentation/Settings.hs +++ b/lib/Patat/Presentation/Settings.hs @@ -248,6 +248,7 @@ data EvalSettings = EvalSettings , evalReplace :: !Bool , evalFragment :: !Bool , evalContainer :: !EvalSettingsContainer + , evalStderr :: !Bool } deriving (Show) @@ -258,6 +259,7 @@ instance A.FromJSON EvalSettings where <*> o A..:? "replace" A..!= False <*> o A..:? "fragment" A..!= True <*> deprecated "wrap" "container" EvalContainerCode o + <*> o A..:? "stderr" A..!= True where deprecated old new def obj = do mo <- obj A..:? old 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 diff --git a/tests/golden/inputs/eval08.md b/tests/golden/inputs/eval08.md new file mode 100644 index 0000000..06139d1 --- /dev/null +++ b/tests/golden/inputs/eval08.md @@ -0,0 +1,38 @@ +--- +patat: + eval: + implicitStderr: + command: sh + replace: true + fragment: false + withStderr: + command: sh + replace: true + fragment: false + stderr: true + withoutStderr: + command: sh + replace: true + fragment: false + stderr: false +... + +# Slide + +~~~{.implicitStderr} +echo "Hello stdout" +sleep 0.1 +echo "Hello stderr" >&2 +~~~ + +~~~{.withStderr} +echo "Hello stdout" +sleep 0.1 +echo "Hello stderr" >&2 +~~~ + +~~~{.withoutStderr} +echo "Hello stdout" +sleep 0.1 +echo "Hello stderr" >&2 +~~~ diff --git a/tests/golden/outputs/eval08.md.dump b/tests/golden/outputs/eval08.md.dump new file mode 100644 index 0000000..b389be2 --- /dev/null +++ b/tests/golden/outputs/eval08.md.dump @@ -0,0 +1,19 @@ + eval08.md  + +# Slide + +   +  Hello stdout  +  Hello stderr  +   + +   +  Hello stdout  +  Hello stderr  +   + +   +  Hello stdout  +   + + 1 / 1