diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ # Changelog +## 0.14.0.0 (2024-02-06) + + * Align based on final layout for incremental lists and other fragments + (#174). This avoids lists "jumping around" as they are revealed when + using `auto` `margins`. + + * Rename `fragment` to `reveal` in eval settings. `fragment` will continue + to be available for backwards-compatibility. + + * Use a temporary file to atomically write speaker notes. + + We weren't writing the file all-at-once before, so if you were using a + simple tool like `tail -F` before, this could cause some speaker notes to + not be displayed. + + * Refactor the internal AST to use our own derivation of the Pandoc AST. + This is a major rework of the internals but should not cause any changes + visible to the user. + ## 0.13.0.0 (2024-10-30) * Incrementally display output of `eval` commands (#132) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -407,7 +407,7 @@ ### Fragmented slides -By default, slides are always displayed "all at once". If you want to display +By default, slides are always displayed "all at once". If you want to reveal them fragment by fragment, there are two ways to do that. The most common case is that lists should be displayed incrementally. @@ -650,7 +650,7 @@ In order to do that, for example, we could configure `kitten` code snippets to evaluate using [Kitty]'s command `icat`. This uses the `none` container setting to ensure that the resulting output is not wrapped in a code block, -and the `fragment` and `replace` settings immediately replace the snippet. +and the `reveal` and `replace` settings immediately replace the snippet. --- patat: @@ -658,7 +658,7 @@ kitten: command: sed 's/^/kitten /' | bash replace: true - fragment: false + reveal: false container: none ... @@ -702,7 +702,7 @@ eval: ruby: command: irb --noecho --noverbose - fragment: true # Optional + reveal: true # Optional replace: false # Optional container: code # Optional ... @@ -722,7 +722,7 @@ Aside from the command, there are four more options: - - `fragment`: Introduce a pause (see [fragments](#fragmented-slides)) in + - `reveal`: Introduce a pause (see [fragments](#fragmented-slides)) in between showing the original code block and the output. Defaults to `true`. - `replace`: Remove the original code block and replace it with the output rather than appending the output in a new code block. Defaults to `false`. @@ -735,8 +735,10 @@ - `stderr`: Include output from standard error. Defaults to `true`. - `wrap`: this is a deprecated name for `container`, used in version 0.11 and earlier. + - `fragment`: this is a deprecated name for `reveal`, used in version 0.13 and + earlier. -Setting `fragment: false` and `replace: true` offers a way to "filter" code +Setting `reveal: false` and `replace: true` offers a way to "filter" code blocks, which can be used to render ASCII graphics. --- @@ -744,7 +746,7 @@ eval: figlet: command: figlet - fragment: false + reveal: false replace: true ... @@ -791,13 +793,11 @@ ``` Then, you can display these in a second terminal (presumably on a second -monitor) by just displaying this file whenever it changes. [entr] is one -way to do that: - -[entr]: http://eradman.com/entrproject/ +monitor) by just displaying this file whenever it changes. `tail` is a primitive +way of doing that: ```bash -echo /tmp/notes.txt | entr -s 'clear; cat /tmp/notes.txt' +tail -F /tmp/notes.txt ``` Alternatively, just use a second `patat` instance with `--watch` enabled: diff --git a/lib/Data/Aeson/Extended.hs b/lib/Data/Aeson/Extended.hs --- a/lib/Data/Aeson/Extended.hs +++ b/lib/Data/Aeson/Extended.hs @@ -14,7 +14,7 @@ -- | This can be parsed from a JSON string in addition to a JSON number. newtype FlexibleNum a = FlexibleNum {unFlexibleNum :: a} - deriving (Show, ToJSON) + deriving (Eq, Show, ToJSON) instance (FromJSON a, Read a) => FromJSON (FlexibleNum a) where parseJSON (String str) = case readMaybe (T.unpack str) of diff --git a/lib/Data/Data/Extended.hs b/lib/Data/Data/Extended.hs deleted file mode 100644 --- a/lib/Data/Data/Extended.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Data.Data.Extended - ( module Data.Data - - , grecQ - , grecT - ) where - -import Data.Data - --- | Recursively find all values of a certain type. -grecQ :: (Data a, Data b) => a -> [b] -grecQ = concat . gmapQ (\x -> maybe id (:) (cast x) $ grecQ x) - --- | Recursively apply an update to a certain type. -grecT :: (Data a, Data b) => (a -> a) -> b -> b -grecT f x = gmapT (grecT f) (castMap f x) - -castMap :: (Typeable a, Typeable b) => (a -> a) -> b -> b -castMap f x = case cast x of - Nothing -> x - Just y -> case cast (f y) of - Nothing -> x - Just z -> z diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs --- a/lib/Patat/Eval.hs +++ b/lib/Patat/Eval.hs @@ -11,33 +11,34 @@ -------------------------------------------------------------------------------- -import qualified Control.Concurrent.Async as Async -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 qualified Control.Concurrent.Async as Async +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.Set as S +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 System.Exit (ExitCode (..)) -import qualified System.IO as IO -import qualified System.Process as Process -import qualified Text.Pandoc.Definition as Pandoc +import Patat.Presentation.Syntax +import Patat.Unique +import System.Exit (ExitCode (..)) +import qualified System.IO as IO +import qualified System.Process as Process -------------------------------------------------------------------------------- parseEvalBlocks :: Presentation -> Presentation parseEvalBlocks presentation = let ((pres, varGen), evalBlocks) = runWriter $ - runStateT work (pVarGen presentation) in - pres {pEvalBlocks = evalBlocks, pVarGen = varGen} + runStateT work (pUniqueGen presentation) in + pres {pEvalBlocks = evalBlocks, pUniqueGen = varGen} where work = case psEval (pSettings presentation) of Nothing -> pure presentation @@ -56,56 +57,51 @@ -------------------------------------------------------------------------------- -- | Monad used for identifying and extracting the evaluation blocks from a -- presentation. -type ExtractEvalM a = StateT VarGen (Writer (HMS.HashMap Var EvalBlock)) a +type ExtractEvalM a = StateT UniqueGen (Writer (HMS.HashMap Var EvalBlock)) a -------------------------------------------------------------------------------- evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide evalSlide settings slide = case slideContent slide of TitleSlide _ _ -> pure slide - ContentSlide instrs0 -> do - instrs1 <- traverse (evalInstruction settings) (toList instrs0) - pure slide {slideContent = ContentSlide . fromList $ concat instrs1} - - --------------------------------------------------------------------------------- -evalInstruction - :: EvalSettingsMap -> 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] + ContentSlide blocks -> do + blocks1 <- dftBlocks (evalBlock settings) (pure . pure) blocks + pure slide {slideContent = ContentSlide blocks1} -------------------------------------------------------------------------------- evalBlock - :: EvalSettingsMap -> Pandoc.Block - -> ExtractEvalM [Instruction Pandoc.Block] -evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt) + :: EvalSettingsMap -> Block + -> ExtractEvalM [Block] +evalBlock settings orig@(CodeBlock attr@(_, classes, _) txt) | [s@EvalSettings {..}] <- lookupSettings classes settings = do - var <- state freshVar + var <- Var <$> state freshUnique tell $ HMS.singleton var $ EvalBlock s attr txt Nothing - pure $ case (evalFragment, evalReplace) of - (False, True) -> [AppendVar var] - (False, False) -> [Append [orig], AppendVar var] - (True, True) -> - [ Append [orig], Pause - , Delete, AppendVar var - ] - (True, False) -> - [Append [orig], Pause, AppendVar var] + case (evalReveal, evalReplace) of + (False, True) -> pure [VarBlock var] + (False, False) -> pure [orig, VarBlock var] + (True, True) -> do + revealID <- RevealID <$> state freshUnique + pure $ pure $ Reveal ConcatWrapper $ RevealSequence + revealID + [revealID] + [ (S.singleton 0, [orig]) + , (S.singleton 1, [VarBlock var]) + ] + (True, False) -> do + revealID <- RevealID <$> state freshUnique + pure $ pure $ Reveal ConcatWrapper $ RevealSequence + revealID + [revealID] + [ (S.fromList [0, 1], [orig]) + , (S.fromList [1], [VarBlock var]) + ] | _ : _ : _ <- lookupSettings classes settings = let msg = "patat eval matched multiple settings for " <> T.intercalate "," classes in - pure [Append [Pandoc.CodeBlock attr msg]] + pure [CodeBlock attr msg] evalBlock _ block = - pure [Append [block]] + pure [block] -------------------------------------------------------------------------------- @@ -117,7 +113,7 @@ -------------------------------------------------------------------------------- -evalVar :: Var -> ([Pandoc.Block] -> IO ()) -> Presentation -> IO Presentation +evalVar :: Var -> ([Block] -> IO ()) -> Presentation -> IO Presentation evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of Nothing -> pure presentation Just EvalBlock {..} | Just _ <- ebAsync -> pure presentation @@ -159,7 +155,7 @@ -------------------------------------------------------------------------------- evalActiveVars - :: (Var -> [Pandoc.Block] -> IO ()) -> Presentation -> IO Presentation + :: (Var -> [Block] -> IO ()) -> Presentation -> IO Presentation evalActiveVars update presentation = foldM (\p var -> evalVar var (update var) p) presentation diff --git a/lib/Patat/Eval/Internal.hs b/lib/Patat/Eval/Internal.hs --- a/lib/Patat/Eval/Internal.hs +++ b/lib/Patat/Eval/Internal.hs @@ -11,8 +11,8 @@ 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 Patat.Presentation.Syntax import qualified Text.Pandoc as Pandoc @@ -31,10 +31,10 @@ -------------------------------------------------------------------------------- -renderEvalBlock :: EvalBlock -> T.Text -> [Pandoc.Block] +renderEvalBlock :: EvalBlock -> T.Text -> [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]] + EvalContainerCode -> [CodeBlock ebAttr out] + EvalContainerNone -> [RawBlock fmt out] + EvalContainerInline -> [Plain [RawInline fmt out]] where fmt = "eval" diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs --- a/lib/Patat/Main.hs +++ b/lib/Patat/Main.hs @@ -27,7 +27,7 @@ import qualified Patat.Eval as Eval import qualified Patat.Images as Images import Patat.Presentation -import qualified Patat.Presentation.Comments as Comments +import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes import qualified Patat.PrettyPrint as PP import Patat.PrettyPrint.Matrix (hPutMatrix) import Patat.Transition @@ -127,7 +127,7 @@ data App = App { aOptions :: Options , aImages :: Maybe Images.Handle - , aSpeakerNotes :: Maybe Comments.SpeakerNotesHandle + , aSpeakerNotes :: Maybe SpeakerNotes.Handle , aCommandChan :: Chan AppCommand , aPresentation :: Presentation , aView :: AppView @@ -161,7 +161,7 @@ OA.parserFailure parserPrefs parserInfo (OA.ShowHelpText Nothing) mempty - errOrPres <- readPresentation zeroVarGen filePath + errOrPres <- readPresentation zeroUniqueGen filePath pres <- either (errorAndExit . return) return errOrPres let settings = pSettings pres @@ -175,7 +175,7 @@ withMaybeHandle Images.withHandle (psImages settings) $ \images -> -- (Maybe) initialize speaker notes. - withMaybeHandle Comments.withSpeakerNotesHandle + withMaybeHandle SpeakerNotes.withHandle (psSpeakerNotes settings) $ \speakerNotes -> -- Read presentation commands @@ -206,7 +206,7 @@ -------------------------------------------------------------------------------- loop :: App -> IO () loop app@App {..} = do - for_ aSpeakerNotes $ \sn -> Comments.writeSpeakerNotes sn + for_ aSpeakerNotes $ \sn -> SpeakerNotes.write sn (pEncodingFallback aPresentation) (activeSpeakerNotes aPresentation) diff --git a/lib/Patat/Presentation.hs b/lib/Patat/Presentation.hs --- a/lib/Patat/Presentation.hs +++ b/lib/Patat/Presentation.hs @@ -2,9 +2,9 @@ ( PresentationSettings (..) , defaultPresentationSettings - , VarGen - , Var - , zeroVarGen + , UniqueGen + , Unique + , zeroUniqueGen , Presentation (..) , readPresentation @@ -27,7 +27,7 @@ ) where import Patat.Presentation.Display -import Patat.Presentation.Instruction import Patat.Presentation.Interactive import Patat.Presentation.Internal import Patat.Presentation.Read +import Patat.Unique diff --git a/lib/Patat/Presentation/Comments.hs b/lib/Patat/Presentation/Comments.hs deleted file mode 100644 --- a/lib/Patat/Presentation/Comments.hs +++ /dev/null @@ -1,174 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Patat.Presentation.Comments - ( Comment (..) - , parse - , remove - , split - , partition - - , SpeakerNotes - , speakerNotesToText - - , SpeakerNotesHandle - , withSpeakerNotesHandle - , writeSpeakerNotes - - , parseSlideSettings - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<|>)) -import Control.Exception (bracket) -import Control.Monad (unless, when) -import Data.Function (on) -import qualified Data.IORef as IORef -import Data.List (intercalate, intersperse) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Yaml as Yaml -import Patat.EncodingFallback (EncodingFallback) -import qualified Patat.EncodingFallback as EncodingFallback -import Patat.Presentation.Settings -import System.Directory (removeFile) -import qualified System.IO as IO -import qualified Text.Pandoc as Pandoc - - --------------------------------------------------------------------------------- -data Comment = Comment - { cSpeakerNotes :: SpeakerNotes - , cConfig :: Either String PresentationSettings - } deriving (Show) - - --------------------------------------------------------------------------------- -instance Semigroup Comment where - l <> r = Comment - { cSpeakerNotes = on (<>) cSpeakerNotes l r - , cConfig = case (cConfig l, cConfig r) of - (Left err, _ ) -> Left err - (Right _, Left err) -> Left err - (Right x, Right y ) -> Right (x <> y) - } - - --------------------------------------------------------------------------------- -instance Monoid Comment where - mappend = (<>) - mempty = Comment mempty (Right mempty) - - --------------------------------------------------------------------------------- -parse :: Pandoc.Block -> Maybe Comment -parse (Pandoc.RawBlock "html" t0) = - (do - t1 <- T.stripPrefix "" t1 - pure . Comment mempty $ case Yaml.decodeEither' (T.encodeUtf8 t2) of - Left err -> Left (show err) - Right obj -> Right obj) <|> - (do - t1 <- T.stripPrefix "" t1 - pure $ Comment (SpeakerNotes [T.strip t2]) (Right mempty)) -parse _ = Nothing - - --------------------------------------------------------------------------------- -remove :: [Pandoc.Block] -> [Pandoc.Block] -remove = snd . partition - - --------------------------------------------------------------------------------- --- | Take all comments from the front of the list. Return those and the --- remaining blocks. -split :: [Pandoc.Block] -> (Comment, [Pandoc.Block]) -split = go [] - where - go sn [] = (mconcat (reverse sn), []) - go sn (x : xs) | Just s <- parse x = go (s : sn) xs - go sn xs = (mconcat (reverse sn), xs) - - --------------------------------------------------------------------------------- --- | Partition the list into speaker notes and other blocks. -partition :: [Pandoc.Block] -> (Comment, [Pandoc.Block]) -partition = go [] [] - where - go sn bs [] = (mconcat (reverse sn), reverse bs) - go sn bs (x : xs) | Just s <- parse x = go (s : sn) bs xs - go sn bs (x : xs) = go sn (x : bs) xs - - --------------------------------------------------------------------------------- -newtype SpeakerNotes = SpeakerNotes [T.Text] - deriving (Eq, Monoid, Semigroup, Show) - - --------------------------------------------------------------------------------- -speakerNotesToText :: SpeakerNotes -> T.Text -speakerNotesToText (SpeakerNotes sn) = T.unlines $ intersperse mempty sn - - --------------------------------------------------------------------------------- -data SpeakerNotesHandle = SpeakerNotesHandle - { snhSettings :: !SpeakerNotesSettings - , snhActive :: !(IORef.IORef SpeakerNotes) - } - - --------------------------------------------------------------------------------- -withSpeakerNotesHandle - :: SpeakerNotesSettings -> (SpeakerNotesHandle -> IO a) -> IO a -withSpeakerNotesHandle settings = bracket - (SpeakerNotesHandle settings <$> IORef.newIORef mempty) - (\_ -> removeFile (snsFile settings)) - - --------------------------------------------------------------------------------- -writeSpeakerNotes - :: SpeakerNotesHandle -> EncodingFallback -> SpeakerNotes -> IO () -writeSpeakerNotes h encodingFallback sn = do - change <- IORef.atomicModifyIORef' (snhActive h) $ \old -> (sn, old /= sn) - when change $ IO.withFile (snsFile $ snhSettings h) IO.WriteMode $ \ioh -> - EncodingFallback.withHandle ioh encodingFallback $ - T.hPutStr ioh $ speakerNotesToText sn - - --------------------------------------------------------------------------------- -data Setting where - Setting :: String -> (PresentationSettings -> Maybe a) -> Setting - - --------------------------------------------------------------------------------- -unsupportedSlideSettings :: [Setting] -unsupportedSlideSettings = - [ Setting "incrementalLists" psIncrementalLists - , Setting "autoAdvanceDelay" psAutoAdvanceDelay - , Setting "slideLevel" psSlideLevel - , Setting "pandocExtensions" psPandocExtensions - , Setting "images" psImages - , Setting "eval" psEval - , Setting "speakerNotes" psSpeakerNotes - ] - - --------------------------------------------------------------------------------- -parseSlideSettings :: Comment -> Either String PresentationSettings -parseSlideSettings c = do - settings <- cConfig c - let unsupported = do - setting <- unsupportedSlideSettings - case setting of - Setting name f | Just _ <- f settings -> [name] - Setting _ _ -> [] - unless (null unsupported) $ Left $ - "the following settings are not supported in slide config blocks: " ++ - intercalate ", " unsupported - pure settings diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs --- a/lib/Patat/Presentation/Display.hs +++ b/lib/Patat/Presentation/Display.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Patat.Presentation.Display @@ -11,19 +12,23 @@ -------------------------------------------------------------------------------- import Control.Monad (guard) +import Control.Monad.Identity (runIdentity) +import Control.Monad.Writer (Writer, execWriter, tell) import qualified Data.Aeson.Extended as A import Data.Char.WCWidth.Extended (wcstrwidth) -import Data.Data.Extended (grecQ) +import Data.Foldable (for_) +import qualified Data.HashMap.Strict as HMS import qualified Data.List as L import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Sequence.Extended as Seq import qualified Data.Text as T -import qualified Patat.Presentation.Comments as Comments import Patat.Presentation.Display.CodeBlock import Patat.Presentation.Display.Internal import Patat.Presentation.Display.Table import Patat.Presentation.Internal import Patat.Presentation.Settings +import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes +import Patat.Presentation.Syntax import Patat.PrettyPrint ((<$$>), (<+>)) import qualified Patat.PrettyPrint as PP import Patat.Size @@ -31,7 +36,6 @@ import qualified Patat.Theme as Theme import Prelude import qualified Text.Pandoc.Extended as Pandoc -import qualified Text.Pandoc.Writers.Shared as Pandoc -------------------------------------------------------------------------------- @@ -56,17 +60,23 @@ PP.hardline where -- Get terminal width/title - (sidx, _) = pActiveFragment - settings = activeSettings pres - ds = DisplaySettings + settings = activeSettings pres + (sidx, _) = pActiveFragment + ds = DisplaySettings { dsSize = canvasSize , dsMargins = margins settings , dsWrap = fromMaybe NoWrap $ psWrap settings , dsTabStop = maybe 4 A.unFlexibleNum $ psTabStop settings , dsTheme = fromMaybe Theme.defaultTheme (psTheme settings) , dsSyntaxMap = pSyntaxMap + , dsResolve = \var -> fromMaybe [] $ HMS.lookup var pVars + , dsRevealState = revealState } + revealState = case activeFragment pres of + Just (ActiveContent _ _ c) -> c + _ -> mempty + -- Compute title. breadcrumbs = fromMaybe [] $ Seq.safeIndex pBreadcrumbs sidx plainTitle = PP.toString $ prettyInlines ds pTitle @@ -103,26 +113,25 @@ 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 + prettyMargins theme fragment Just (ActiveTitle block) -> DisplayDoc $ displayWithBorders size pres $ \ds -> let auto = Margins {mTop = Auto, mRight = Auto, mLeft = Auto} in - prettyFragment ds {dsMargins = auto} $ Fragment [block] - + prettyMargins ds {dsMargins = auto} [block] where -- Check if the fragment consists of "just a single image". Discard -- headers. - onlyImage (Fragment (Pandoc.Header{} : bs)) = onlyImage (Fragment bs) - onlyImage (Fragment bs) = case bs of - [Pandoc.Figure _ _ bs'] -> onlyImage (Fragment bs') - [Pandoc.Para [Pandoc.Image _ _ (target, _)]] -> Just target - _ -> Nothing + onlyImage (Header{} : bs) = onlyImage bs + onlyImage bs = case bs of + [Figure _ bs'] -> onlyImage bs' + [Para [Image _ _ (target, _)]] -> Just target + _ -> Nothing -------------------------------------------------------------------------------- @@ -145,18 +154,16 @@ dumpSlide :: Int -> [PP.Doc] dumpSlide i = do slide <- maybeToList $ getSlide i pres - dumpComment slide <> L.intercalate ["{fragment}"] + dumpSpeakerNotes slide <> L.intercalate ["{fragment}"] [ dumpFragment (i, j) | j <- [0 .. numFragments slide - 1] ] - dumpComment :: Slide -> [PP.Doc] - dumpComment slide = do - guard (Comments.cSpeakerNotes comment /= mempty) + dumpSpeakerNotes :: Slide -> [PP.Doc] + dumpSpeakerNotes slide = do + guard (slideSpeakerNotes slide /= mempty) pure $ PP.text $ "{speakerNotes: " <> - Comments.speakerNotesToText (Comments.cSpeakerNotes comment) <> "}" - where - comment = slideComment slide + SpeakerNotes.toText (slideSpeakerNotes slide) <> "}" dumpFragment :: Index -> [PP.Doc] dumpFragment idx = @@ -173,31 +180,68 @@ -------------------------------------------------------------------------------- -prettyFragment :: DisplaySettings -> Fragment -> PP.Doc -prettyFragment ds (Fragment blocks) = vertical $ - PP.vcat (map (horizontal . prettyBlock ds) blocks) <> +-- | Renders the given blocks, adding margins based on the settings and wrapping +-- based on width. +prettyMargins :: DisplaySettings -> [Block] -> PP.Doc +prettyMargins ds blocks = vertical $ + map horizontal blocks ++ case prettyReferences ds blocks of - [] -> mempty - refs -> PP.hardline <> PP.vcat (map horizontal refs) + [] -> [] + refs -> + let doc0 = PP.vcat refs + size@(r, _) = PP.dimensions doc0 in + [(horizontalIndent size $ horizontalWrap doc0, r)] where Size rows columns = dsSize ds Margins {..} = dsMargins ds - vertical doc0 = - mconcat (replicate top PP.hardline) <> doc0 + -- For every block, calculate the size based on its last fragment. + blockSize block = + let revealState = blocksRevealLastStep [block] in + PP.dimensions $ deindent $ horizontalWrap $ + prettyBlock ds {dsRevealState = revealState} block + + -- Vertically align some blocks by adding spaces in front of it. + -- We also take in the number of rows for every block so we don't + -- need to recompute it. + vertical :: [(PP.Doc, Int)] -> PP.Doc + vertical docs0 = mconcat (replicate top PP.hardline) <> doc where top = case mTop of - Auto -> let (r, _) = PP.dimensions doc0 in (rows - r) `div` 2 + Auto -> (rows - actual) `div` 2 NotAuto x -> x - horizontal = horizontalIndent . horizontalWrap + docs1 = [verticalPad r d | (d, r) <- docs0] + actual = sum $ L.intersperse 1 $ map snd docs1 + doc = PP.vcat $ map fst docs1 - horizontalIndent doc0 = PP.indent indentation indentation doc1 + -- Vertically pad a doc by adding lines below it. + -- Return the actual size as well as the padded doc. + verticalPad :: Int -> PP.Doc -> (PP.Doc, Int) + verticalPad desired doc0 + | actual >= rows = (doc0, actual) + | otherwise = (doc0 <> padding, desired) where - doc1 = case (mLeft, mRight) of - (Auto, Auto) -> PP.deindent doc0 - _ -> doc0 - (_, dcols) = PP.dimensions doc1 + (actual, _) = PP.dimensions doc0 + padding = mconcat $ replicate (desired - actual) PP.hardline + + -- Render and horizontally align a block. Also returns the desired rows. + horizontal :: Block -> (PP.Doc, Int) + horizontal b@(Reveal ConcatWrapper reveal) = + -- Horizontally aligning a fragment with a ConcatWrapper is a special + -- case, as we want to horizontal align all the things inside + -- individually. + let (fblocks, _) = unzip $ map horizontal $ + revealToBlocks (dsRevealState ds) ConcatWrapper reveal in + (PP.vcat fblocks, fst (blockSize b)) + horizontal block = + let size@(r, _) = blockSize block in + (horizontalIndent size $ horizontalWrap $ prettyBlock ds block, r) + + horizontalIndent :: (Int, Int) -> PP.Doc -> PP.Doc + horizontalIndent (_, dcols) doc0 = PP.indent indentation indentation doc1 + where + doc1 = deindent doc0 left = case mLeft of NotAuto x -> x Auto -> case mRight of @@ -205,6 +249,13 @@ Auto -> (columns - dcols) `div` 2 indentation = PP.Indentation left mempty + -- Strip leading spaces to horizontally align code blocks etc. + deindent doc0 = case (mLeft, mRight) of + (Auto, Auto) -> PP.deindent doc0 + _ -> doc0 + + -- Rearranges lines to fit into the wrap settings. + horizontalWrap :: PP.Doc -> PP.Doc horizontalWrap doc0 = case dsWrap ds of NoWrap -> doc0 AutoWrap -> PP.wrapAt (Just $ columns - right - left) doc0 @@ -219,21 +270,21 @@ -------------------------------------------------------------------------------- -prettyBlock :: DisplaySettings -> Pandoc.Block -> PP.Doc +prettyBlock :: DisplaySettings -> Block -> PP.Doc -prettyBlock ds (Pandoc.Plain inlines) = prettyInlines ds inlines +prettyBlock ds (Plain inlines) = prettyInlines ds inlines -prettyBlock ds (Pandoc.Para inlines) = +prettyBlock ds (Para inlines) = prettyInlines ds inlines <> PP.hardline -prettyBlock ds (Pandoc.Header i _ inlines) = +prettyBlock ds (Header i _ inlines) = themed ds themeHeader (PP.string (replicate i '#') <+> prettyInlines ds inlines) <> PP.hardline -prettyBlock ds (Pandoc.CodeBlock (_, classes, _) txt) = +prettyBlock ds (CodeBlock (_, classes, _) txt) = prettyCodeBlock ds classes txt -prettyBlock ds (Pandoc.BulletList bss) = PP.vcat +prettyBlock ds (BulletList bss) = PP.vcat [ PP.indent (PP.Indentation 2 $ themed ds themeBulletList prefix) (PP.Indentation 4 mempty) @@ -254,7 +305,7 @@ } ds' = ds {dsTheme = theme'} -prettyBlock ds (Pandoc.OrderedList _ bss) = PP.vcat +prettyBlock ds (OrderedList _ bss) = PP.vcat [ PP.indent (PP.Indentation 0 $ themed ds themeOrderedList $ PP.string prefix) (PP.Indentation 4 mempty) @@ -268,15 +319,15 @@ | i <- [1 .. length bss] ] -prettyBlock _ds (Pandoc.RawBlock _ t) = PP.text t <> PP.hardline +prettyBlock _ds (RawBlock _ t) = PP.text t <> PP.hardline -prettyBlock _ds Pandoc.HorizontalRule = "---" +prettyBlock _ds HorizontalRule = "---" -prettyBlock ds (Pandoc.BlockQuote bs) = +prettyBlock ds (BlockQuote bs) = let quote = PP.Indentation 0 (themed ds themeBlockQuote "> ") in PP.indent quote quote (themed ds themeBlockQuote $ prettyBlocks ds bs) -prettyBlock ds (Pandoc.DefinitionList terms) = +prettyBlock ds (DefinitionList terms) = PP.vcat $ map prettyDefinition terms where prettyDefinition (term, definitions) = @@ -285,134 +336,157 @@ [ PP.indent (PP.Indentation 0 (themed ds themeDefinitionList ": ")) (PP.Indentation 4 mempty) $ - prettyBlocks ds (Pandoc.plainToPara definition) + prettyBlocks ds (plainToPara definition) | definition <- definitions ] -prettyBlock ds (Pandoc.Table _ caption specs thead tbodies tfoot) = + plainToPara :: [Block] -> [Block] + plainToPara = map $ \case + Plain inlines -> Para inlines + block -> block + + +prettyBlock ds (Table caption aligns headers rows) = PP.wrapAt Nothing $ - prettyTable ds Table - { tCaption = prettyInlines ds caption' - , tAligns = map align aligns - , tHeaders = map (prettyBlocks ds) headers - , tRows = map (map (prettyBlocks ds)) rows + prettyTableDisplay ds TableDisplay + { tdCaption = prettyInlines ds caption + , tdAligns = map align aligns + , tdHeaders = map (prettyBlocks ds) headers + , tdRows = map (map (prettyBlocks ds)) rows } where - (caption', aligns, _, headers, rows) = Pandoc.toLegacyTable - caption specs thead tbodies tfoot - align Pandoc.AlignLeft = PP.AlignLeft align Pandoc.AlignCenter = PP.AlignCenter align Pandoc.AlignDefault = PP.AlignLeft align Pandoc.AlignRight = PP.AlignRight -prettyBlock ds (Pandoc.Div _attrs blocks) = prettyBlocks ds blocks +prettyBlock ds (Div _attrs blocks) = prettyBlocks ds blocks -prettyBlock ds (Pandoc.LineBlock inliness) = +prettyBlock ds (LineBlock inliness) = let ind = PP.Indentation 0 (themed ds themeLineBlock "| ") in PP.wrapAt Nothing $ PP.indent ind ind $ PP.vcat $ map (prettyInlines ds) inliness -prettyBlock ds (Pandoc.Figure _attr _caption blocks) = - prettyBlocks ds blocks +prettyBlock ds (Figure _attr blocks) = prettyBlocks ds blocks +prettyBlock ds (Reveal w fragment) = prettyBlocks ds $ + revealToBlocks (dsRevealState ds) w fragment +prettyBlock ds (VarBlock var) = prettyBlocks ds $ dsResolve ds var + +prettyBlock _ (SpeakerNote _) = mempty +prettyBlock _ (Config _) = mempty + + -------------------------------------------------------------------------------- -prettyBlocks :: DisplaySettings -> [Pandoc.Block] -> PP.Doc +prettyBlocks :: DisplaySettings -> [Block] -> PP.Doc prettyBlocks ds = PP.vcat . map (prettyBlock ds) -------------------------------------------------------------------------------- -prettyInline :: DisplaySettings -> Pandoc.Inline -> PP.Doc +prettyInline :: DisplaySettings -> Inline -> PP.Doc -prettyInline _ds Pandoc.Space = PP.space +prettyInline _ds Space = PP.space -prettyInline _ds (Pandoc.Str str) = PP.text str +prettyInline _ds (Str str) = PP.text str -prettyInline ds (Pandoc.Emph inlines) = +prettyInline ds (Emph inlines) = themed ds themeEmph $ prettyInlines ds inlines -prettyInline ds (Pandoc.Strong inlines) = +prettyInline ds (Strong inlines) = themed ds themeStrong $ prettyInlines ds inlines -prettyInline ds (Pandoc.Underline inlines) = +prettyInline ds (Underline inlines) = themed ds themeUnderline $ prettyInlines ds inlines -prettyInline ds (Pandoc.Code _ txt) = +prettyInline ds (Code _ txt) = themed ds themeCode $ PP.text (" " <> txt <> " ") -prettyInline ds link@(Pandoc.Link _attrs text (target, _title)) - | isReferenceLink link = +prettyInline ds link@(Link _attrs _text (target, _title)) + | Just (text, _, _) <- toReferenceLink link = "[" <> themed ds themeLinkText (prettyInlines ds text) <> "]" | otherwise = "<" <> themed ds themeLinkTarget (PP.text target) <> ">" -prettyInline _ds Pandoc.SoftBreak = PP.softline +prettyInline _ds SoftBreak = PP.softline -prettyInline _ds Pandoc.LineBreak = PP.hardline +prettyInline _ds LineBreak = PP.hardline -prettyInline ds (Pandoc.Strikeout t) = +prettyInline ds (Strikeout t) = "~~" <> themed ds themeStrikeout (prettyInlines ds t) <> "~~" -prettyInline ds (Pandoc.Quoted Pandoc.SingleQuote t) = +prettyInline ds (Quoted Pandoc.SingleQuote t) = "'" <> themed ds themeQuoted (prettyInlines ds t) <> "'" -prettyInline ds (Pandoc.Quoted Pandoc.DoubleQuote t) = +prettyInline ds (Quoted Pandoc.DoubleQuote t) = "'" <> themed ds themeQuoted (prettyInlines ds t) <> "'" -prettyInline ds (Pandoc.Math _ t) = +prettyInline ds (Math _ t) = themed ds themeMath (PP.text t) -prettyInline ds (Pandoc.Image _attrs text (target, _title)) = +prettyInline ds (Image _attrs text (target, _title)) = "![" <> themed ds themeImageText (prettyInlines ds text) <> "](" <> themed ds themeImageTarget (PP.text target) <> ")" -prettyInline _ (Pandoc.RawInline _ t) = PP.text t +prettyInline _ (RawInline _ t) = PP.text t -- These elements aren't really supported. -prettyInline ds (Pandoc.Cite _ t) = prettyInlines ds t -prettyInline ds (Pandoc.Span _ t) = prettyInlines ds t -prettyInline ds (Pandoc.Note t) = prettyBlocks ds t -prettyInline ds (Pandoc.Superscript t) = prettyInlines ds t -prettyInline ds (Pandoc.Subscript t) = prettyInlines ds t -prettyInline ds (Pandoc.SmallCaps t) = prettyInlines ds t +prettyInline ds (Cite _ t) = prettyInlines ds t +prettyInline ds (Span _ t) = prettyInlines ds t +prettyInline _ (Note _) = mempty -- TODO: support notes? +prettyInline ds (Superscript t) = prettyInlines ds t +prettyInline ds (Subscript t) = prettyInlines ds t +prettyInline ds (SmallCaps t) = prettyInlines ds t -- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported -------------------------------------------------------------------------------- -prettyInlines :: DisplaySettings -> [Pandoc.Inline] -> PP.Doc +prettyInlines :: DisplaySettings -> [Inline] -> PP.Doc prettyInlines ds = mconcat . map (prettyInline ds) -------------------------------------------------------------------------------- -prettyReferences :: DisplaySettings -> [Pandoc.Block] -> [PP.Doc] +type Reference = ([Inline], T.Text, T.Text) + + +-------------------------------------------------------------------------------- +prettyReferences :: DisplaySettings -> [Block] -> [PP.Doc] prettyReferences ds = - map prettyReference . getReferences + map prettyReference . execWriter . dftBlocks (pure . pure) tellReference where - getReferences :: [Pandoc.Block] -> [Pandoc.Inline] - getReferences = filter isReferenceLink . grecQ + tellReference :: Inline -> Writer [Reference] [Inline] + tellReference inline = do + for_ (toReferenceLink inline) (tell . pure) + pure [inline] - prettyReference :: Pandoc.Inline -> PP.Doc - prettyReference (Pandoc.Link _attrs text (target, title)) = + prettyReference :: Reference -> PP.Doc + prettyReference (text, target, title) = "[" <> themed ds themeLinkText - (prettyInlines ds $ Pandoc.newlineToSpace text) <> + (prettyInlines ds $ newlineToSpace text) <> "](" <> themed ds themeLinkTarget (PP.text target) <> (if T.null title then mempty else PP.space <> "\"" <> PP.text title <> "\"") <> ")" - prettyReference _ = mempty + newlineToSpace :: [Inline] -> [Inline] + newlineToSpace = runIdentity . dftInlines (pure . pure) work + where + work x = pure $ case x of + SoftBreak -> [Space] + LineBreak -> [Space] + _ -> [x] + -------------------------------------------------------------------------------- -isReferenceLink :: Pandoc.Inline -> Bool -isReferenceLink (Pandoc.Link _attrs text (target, _)) = - [Pandoc.Str target] /= text -isReferenceLink _ = False +toReferenceLink :: Inline -> Maybe Reference +toReferenceLink (Link _attrs text (target, title)) + | [Str target] /= text = Just (text, target, title) +toReferenceLink _ = Nothing diff --git a/lib/Patat/Presentation/Display/Internal.hs b/lib/Patat/Presentation/Display/Internal.hs --- a/lib/Patat/Presentation/Display/Internal.hs +++ b/lib/Patat/Presentation/Display/Internal.hs @@ -8,6 +8,7 @@ -------------------------------------------------------------------------------- import Patat.Presentation.Internal (Margins) import Patat.Presentation.Settings (Wrap) +import Patat.Presentation.Syntax (Block, RevealState, Var) import qualified Patat.PrettyPrint as PP import Patat.Size (Size) import qualified Patat.Theme as Theme @@ -16,12 +17,14 @@ -------------------------------------------------------------------------------- data DisplaySettings = DisplaySettings - { dsSize :: !Size - , dsWrap :: !Wrap - , dsTabStop :: !Int - , dsMargins :: !Margins - , dsTheme :: !Theme.Theme - , dsSyntaxMap :: !Skylighting.SyntaxMap + { dsSize :: !Size + , dsWrap :: !Wrap + , dsTabStop :: !Int + , dsMargins :: !Margins + , dsTheme :: !Theme.Theme + , dsSyntaxMap :: !Skylighting.SyntaxMap + , dsResolve :: !(Var -> [Block]) + , dsRevealState :: !RevealState } diff --git a/lib/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs --- a/lib/Patat/Presentation/Display/Table.hs +++ b/lib/Patat/Presentation/Display/Table.hs @@ -2,8 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Patat.Presentation.Display.Table - ( Table (..) - , prettyTable + ( TableDisplay (..) + , prettyTableDisplay , themed ) where @@ -19,47 +19,47 @@ -------------------------------------------------------------------------------- -data Table = Table - { tCaption :: PP.Doc - , tAligns :: [PP.Alignment] - , tHeaders :: [PP.Doc] - , tRows :: [[PP.Doc]] +data TableDisplay = TableDisplay + { tdCaption :: PP.Doc + , tdAligns :: [PP.Alignment] + , tdHeaders :: [PP.Doc] + , tdRows :: [[PP.Doc]] } -------------------------------------------------------------------------------- -prettyTable :: DisplaySettings -> Table -> PP.Doc -prettyTable ds Table {..} = +prettyTableDisplay :: DisplaySettings -> TableDisplay -> PP.Doc +prettyTableDisplay ds TableDisplay {..} = PP.indent indentation indentation $ lineIf (not isHeaderLess) (hcat2 headerHeight [ themed ds themeTableHeader $ PP.align w a (vpad headerHeight header) - | (w, a, header) <- zip3 columnWidths tAligns tHeaders + | (w, a, header) <- zip3 columnWidths tdAligns tdHeaders ]) <> dashedHeaderSeparator ds columnWidths <$$> joinRows [ hcat2 rowHeight [ PP.align w a (vpad rowHeight cell) - | (w, a, cell) <- zip3 columnWidths tAligns row + | (w, a, cell) <- zip3 columnWidths tdAligns row ] - | (rowHeight, row) <- zip rowHeights tRows + | (rowHeight, row) <- zip rowHeights tdRows ] <$$> lineIf isHeaderLess (dashedHeaderSeparator ds columnWidths) <> lineIf - (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption) + (not $ PP.null tdCaption) (PP.hardline <> "Table: " <> tdCaption) where indentation = PP.Indentation 2 mempty lineIf cond line = if cond then line <> PP.hardline else mempty joinRows - | all (all isSimpleCell) tRows = PP.vcat + | all (all isSimpleCell) tdRows = PP.vcat | otherwise = PP.vcat . intersperse "" - isHeaderLess = all PP.null tHeaders + isHeaderLess = all PP.null tdHeaders - headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)] - rowDimensions = map (map PP.dimensions) tRows :: [[(Int, Int)]] + headerDimensions = map PP.dimensions tdHeaders :: [(Int, Int)] + rowDimensions = map (map PP.dimensions) tdRows :: [[(Int, Int)]] columnWidths :: [Int] columnWidths = diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs --- a/lib/Patat/Presentation/Fragment.hs +++ b/lib/Patat/Presentation/Fragment.hs @@ -8,87 +8,151 @@ module Patat.Presentation.Fragment ( FragmentSettings (..) - , fragmentInstructions + , fragmentPresentation , fragmentBlocks , fragmentBlock ) where -import Data.List (intersperse, intercalate) -import Patat.Presentation.Instruction +import Control.Monad.State (State, runState, state) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import Patat.Presentation.Internal +import Patat.Presentation.Syntax +import Patat.Unique import Prelude -import qualified Text.Pandoc as Pandoc +fragmentPresentation :: Presentation -> Presentation +fragmentPresentation presentation = + let (pres, uniqueGen) = runState work (pUniqueGen presentation) in + pres {pUniqueGen = uniqueGen} + where + work = do + slides <- traverse fragmentSlide (pSlides presentation) + pure presentation {pSlides = slides} + + fragmentSlide slide = case slideContent slide of + TitleSlide _ _ -> pure slide + ContentSlide blocks0 -> do + blocks1 <- fragmentBlocks fragmentSettings blocks0 + pure slide {slideContent = ContentSlide blocks1} + + settings = pSettings presentation + fragmentSettings = FragmentSettings + { fsIncrementalLists = fromMaybe False (psIncrementalLists settings) + } + data FragmentSettings = FragmentSettings { fsIncrementalLists :: !Bool } deriving (Show) -fragmentInstructions - :: FragmentSettings - -> Instructions Pandoc.Block -> Instructions Pandoc.Block -fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList +type FragmentM = State UniqueGen + +splitOnThreeDots :: [Block] -> [[Block]] +splitOnThreeDots blocks = case break (== threeDots) blocks of + (pre, _ : post) -> [pre] ++ splitOnThreeDots post + (pre, []) -> [pre] where - 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 + threeDots = Para $ intersperse Space $ replicate 3 (Str ".") fragmentBlocks - :: FragmentSettings -> [Pandoc.Block] -> [Instruction Pandoc.Block] -fragmentBlocks = concatMap . fragmentBlock + :: FragmentSettings -> [Block] -> FragmentM [Block] +fragmentBlocks fs blocks = (>>= fragmentAgainAfterLists) $ + case splitOnThreeDots blocks of + [] -> pure [] + [_] -> concat <$> traverse (fragmentBlock fs) blocks + sections0@(_ : _) -> do + revealID <- RevealID <$> state freshUnique + sections1 <- traverse (fragmentBlocks fs) sections0 + let pauses = length sections1 - 1 + triggers = case sections1 of + [] -> replicate pauses revealID + (sh : st) -> blocksRevealOrder sh ++ + [c | s <- st, c <- revealID : blocksRevealOrder s] + pure $ pure $ Reveal ConcatWrapper $ RevealSequence + revealID + triggers + [(S.fromList [i .. pauses], s) | (i, s) <- zip [0 ..] sections1] -fragmentBlock :: FragmentSettings -> Pandoc.Block -> [Instruction Pandoc.Block] -fragmentBlock _fs block@(Pandoc.Para inlines) - | inlines == threeDots = [Pause] - | otherwise = [Append [block]] - where - threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".") +fragmentBlock :: FragmentSettings -> Block -> FragmentM [Block] +fragmentBlock _fs (Para inlines) = pure [Para inlines] -fragmentBlock fs (Pandoc.BulletList bs0) = - fragmentList fs (fsIncrementalLists fs) Pandoc.BulletList bs0 +fragmentBlock fs (BulletList bs0) = + fragmentList fs (fsIncrementalLists fs) BulletListWrapper bs0 -fragmentBlock fs (Pandoc.OrderedList attr bs0) = - fragmentList fs (fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0 +fragmentBlock fs (OrderedList attr bs0) = + fragmentList fs (fsIncrementalLists fs) (OrderedListWrapper attr) bs0 -fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) = - fragmentList fs (not $ fsIncrementalLists fs) Pandoc.BulletList bs0 +fragmentBlock fs (BlockQuote [BulletList bs0]) = + fragmentList fs (not $ fsIncrementalLists fs) BulletListWrapper bs0 -fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) = - fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0 +fragmentBlock fs (BlockQuote [OrderedList attr bs0]) = + fragmentList fs (not $ fsIncrementalLists fs) (OrderedListWrapper attr) bs0 -fragmentBlock _ block@(Pandoc.BlockQuote {}) = [Append [block]] +fragmentBlock _ block@(BlockQuote {}) = pure [block] -fragmentBlock _ block@(Pandoc.Header {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.Plain {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.CodeBlock {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.RawBlock {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.DefinitionList {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.Table {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.Div {}) = [Append [block]] -fragmentBlock _ block@Pandoc.HorizontalRule = [Append [block]] -fragmentBlock _ block@(Pandoc.LineBlock {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.Figure {}) = [Append [block]] +fragmentBlock _ block@(Header {}) = pure [block] +fragmentBlock _ block@(Plain {}) = pure [block] +fragmentBlock _ block@(CodeBlock {}) = pure [block] +fragmentBlock _ block@(RawBlock {}) = pure [block] +fragmentBlock _ block@(DefinitionList {}) = pure [block] +fragmentBlock _ block@(Table {}) = pure [block] +fragmentBlock _ block@(Div {}) = pure [block] +fragmentBlock _ block@HorizontalRule = pure [block] +fragmentBlock _ block@(LineBlock {}) = pure [block] +fragmentBlock _ block@(Figure {}) = pure [block] +fragmentBlock _ block@(VarBlock {}) = pure [block] +fragmentBlock _ block@(SpeakerNote {}) = pure [block] +fragmentBlock _ block@(Config {}) = pure [block] +fragmentBlock _ block@(Reveal {}) = pure [block] -- Should not happen fragmentList - :: FragmentSettings -- ^ Global settings - -> Bool -- ^ Fragment THIS list? - -> ([[Pandoc.Block]] -> Pandoc.Block) -- ^ List constructor - -> [[Pandoc.Block]] -- ^ List items - -> [Instruction Pandoc.Block] -- ^ Resulting list -fragmentList fs fragmentThisList constructor items = - -- Insert the new list, initially empty. - (if fragmentThisList then [Pause] else []) ++ - [Append [constructor []]] ++ - (map ModifyLast $ - (if fragmentThisList then intercalate [Pause] else concat) $ - map fragmentItem items) + :: FragmentSettings -- ^ Global settings + -> Bool -- ^ Fragment THIS list? + -> RevealWrapper -- ^ List constructor + -> [[Block]] -- ^ List items + -> FragmentM [Block] -- ^ Resulting list +fragmentList fs fragmentThisList rw items0 = do + items1 <- traverse (fragmentBlocks fs) items0 + case fragmentThisList of + False -> pure $ revealWrapper rw items1 + True -> do + revealID <- RevealID <$> state freshUnique + let triggers = [c | s <- items1, c <- revealID : blocksRevealOrder s] + pauses = length items1 + pure $ pure $ Reveal rw $ RevealSequence + revealID + triggers + [ (S.fromList [i .. pauses], s) + | (i, s) <- zip [1 ..] items1 + ] + +-- Insert a final pause after any incremental lists. This needs to happen +-- on the list containing these blocks. +fragmentAgainAfterLists :: [Block] -> FragmentM [Block] +fragmentAgainAfterLists blocks = case splitAfterLists [] blocks of + [] -> pure [] + [_] -> pure blocks + sections@(_ : _) -> do + revealID <- RevealID <$> state freshUnique + let pauses = length sections - 1 + triggers = init + -- Use init to skip the final counter (we don't want to add + -- a pause at the very end since everything is displayed at + -- that point). + [c | s <- sections, c <- blocksRevealOrder s ++ [revealID]] + pure $ pure $ Reveal ConcatWrapper $ RevealSequence + revealID + triggers + [(S.fromList [i .. pauses + 1], s) | (i, s) <- zip [0 ..] sections] where - -- The fragmented list per list item. - fragmentItem :: [Pandoc.Block] -> [Instruction Pandoc.Block] - fragmentItem item = - -- Append a new item to the list so we can start adding - -- content there. - Append [] : - -- Modify this new item to add the content. - map ModifyLast (fragmentBlocks fs item) + splitAfterLists :: [Block] -> [Block] -> [[Block]] + splitAfterLists acc [] = [reverse acc] + splitAfterLists acc (b@(Reveal w _) : bs) + | isListWrapper w, not (null bs) = + reverse (b : acc) : splitAfterLists [] bs + splitAfterLists acc (b : bs) = splitAfterLists (b : acc) bs + + isListWrapper BulletListWrapper = True + isListWrapper (OrderedListWrapper _) = True + isListWrapper ConcatWrapper = False diff --git a/lib/Patat/Presentation/Instruction.hs b/lib/Patat/Presentation/Instruction.hs deleted file mode 100644 --- a/lib/Patat/Presentation/Instruction.hs +++ /dev/null @@ -1,155 +0,0 @@ --------------------------------------------------------------------------------- --- | The Pandoc AST is not extensible, so we need to use another way to model --- different parts of slides that we want to appear bit by bit. --- --- 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 Data.Hashable (Hashable) -import qualified Data.HashSet as HS -import Data.List (foldl') -import qualified Text.Pandoc as Pandoc - -newtype Instructions a = Instructions {unInstructions :: [Instruction a]} - deriving (Show) - --- A smart constructor that guarantees some invariants: --- --- * No consecutive pauses. --- * All pauses moved to the top level. --- * No pauses at the end. -fromList :: [Instruction a] -> Instructions a -fromList = Instructions . go - where - go instrs = case break (not . isPause) instrs of - (_, []) -> [] - (_ : _, remainder) -> Pause : go remainder - ([], x : remainder) -> x : go remainder - -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. - | ModifyLast (Instruction a) - deriving (Show) - -isPause :: Instruction a -> Bool -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 - :: (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 resolve f) xs - -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.OrderedList attr xs -> Pandoc.OrderedList attr $ xs ++ [ys] - _ -> 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 $ 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 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 resolve f) xs - Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ - modifyLast (goBlocks resolve f) xs - _ -> block - -modifyLast :: (a -> a) -> [a] -> [a] -modifyLast f (x : y : zs) = x : modifyLast f (y : zs) -modifyLast f (x : []) = [f x] -modifyLast _ [] = [] - -sinit :: [a] -> [a] -sinit xs = if null xs then [] else init xs diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs --- a/lib/Patat/Presentation/Interactive.hs +++ b/lib/Patat/Presentation/Interactive.hs @@ -14,11 +14,10 @@ -------------------------------------------------------------------------------- import Data.Char (isDigit) -import Patat.Presentation.Instruction (Var) import Patat.Presentation.Internal import Patat.Presentation.Read +import Patat.Presentation.Syntax import qualified System.IO as IO -import qualified Text.Pandoc as Pandoc import Text.Read (readMaybe) @@ -33,7 +32,7 @@ | Last | Reload | Seek Int - | UpdateVar Var [Pandoc.Block] + | UpdateVar Var [Block] | UnknownCommand String deriving (Eq, Show) @@ -137,7 +136,9 @@ } reloadPresentation = do - errOrPres <- readPresentation (pVarGen presentation) (pFilePath presentation) + errOrPres <- readPresentation + (pUniqueGen 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 --- a/lib/Patat/Presentation/Internal.hs +++ b/lib/Patat/Presentation/Internal.hs @@ -22,7 +22,6 @@ , Slide (..) , SlideContent (..) - , Instruction.Fragment (..) , Index , getSlide @@ -44,34 +43,35 @@ -------------------------------------------------------------------------------- -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 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 Patat.Presentation.Settings +import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes +import Patat.Presentation.Syntax import Patat.Size -import Patat.Transition (TransitionGen) +import Patat.Transition (TransitionGen) +import Patat.Unique import Prelude -import qualified Skylighting as Skylighting -import qualified Text.Pandoc as Pandoc +import qualified Skylighting as Skylighting +import qualified Text.Pandoc as Pandoc -------------------------------------------------------------------------------- -type Breadcrumbs = [(Int, [Pandoc.Inline])] +type Breadcrumbs = [(Int, [Inline])] -------------------------------------------------------------------------------- data Presentation = Presentation { pFilePath :: !FilePath , pEncodingFallback :: !EncodingFallback - , pTitle :: ![Pandoc.Inline] - , pAuthor :: ![Pandoc.Inline] + , pTitle :: ![Inline] + , pAuthor :: ![Inline] , pSettings :: !PresentationSettings , pSlides :: !(Seq Slide) , pBreadcrumbs :: !(Seq Breadcrumbs) -- One for each slide. @@ -80,8 +80,8 @@ , pActiveFragment :: !Index , pSyntaxMap :: !Skylighting.SyntaxMap , pEvalBlocks :: !Eval.EvalBlocks - , pVarGen :: !Instruction.VarGen - , pVars :: !(HMS.HashMap Instruction.Var [Pandoc.Block]) + , pUniqueGen :: !UniqueGen + , pVars :: !(HMS.HashMap Var [Block]) } @@ -108,15 +108,16 @@ -------------------------------------------------------------------------------- data Slide = Slide - { slideComment :: !Comments.Comment - , slideContent :: !SlideContent + { slideSpeakerNotes :: !SpeakerNotes.SpeakerNotes + , slideSettings :: !(Either String PresentationSettings) + , slideContent :: !SlideContent } deriving (Show) -------------------------------------------------------------------------------- data SlideContent - = ContentSlide (Instruction.Instructions Pandoc.Block) - | TitleSlide Int [Pandoc.Inline] + = ContentSlide [Block] + | TitleSlide Int [Inline] deriving (Show) @@ -133,14 +134,17 @@ -------------------------------------------------------------------------------- numFragments :: Slide -> Int numFragments slide = case slideContent slide of - ContentSlide instrs -> Instruction.numFragments instrs + ContentSlide blocks -> blocksRevealSteps blocks TitleSlide _ _ -> 1 -------------------------------------------------------------------------------- data ActiveFragment - = ActiveContent Instruction.Fragment - | ActiveTitle Pandoc.Block + = ActiveContent + [Block] + (HS.HashSet Var) + RevealState + | ActiveTitle Block deriving (Show) @@ -151,31 +155,26 @@ slide <- getSlide sidx presentation pure $ case slideContent slide of TitleSlide lvl is -> ActiveTitle $ - Pandoc.Header lvl Pandoc.nullAttr is - ContentSlide instrs -> ActiveContent $ - Instruction.renderFragment resolve $ - Instruction.beforePause fidx instrs - where - resolve var = fromMaybe [] $ HMS.lookup var (pVars presentation) + Header lvl Pandoc.nullAttr is + ContentSlide blocks -> + let vars = variables $ blocksReveal revealState blocks + revealState = blocksRevealStep fidx blocks in + ActiveContent blocks vars revealState -------------------------------------------------------------------------------- -activeSpeakerNotes :: Presentation -> Comments.SpeakerNotes +activeSpeakerNotes :: Presentation -> SpeakerNotes.SpeakerNotes activeSpeakerNotes presentation = fromMaybe mempty $ do let (sidx, _) = pActiveFragment presentation slide <- getSlide sidx presentation - pure . Comments.cSpeakerNotes $ slideComment slide + pure $ slideSpeakerNotes 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 +activeVars :: Presentation -> HS.HashSet Var +activeVars presentation = case activeFragment presentation of + Just (ActiveContent _ vars _) -> vars + _ -> mempty -------------------------------------------------------------------------------- @@ -203,5 +202,5 @@ -------------------------------------------------------------------------------- -updateVar :: Instruction.Var -> [Pandoc.Block] -> Presentation -> Presentation +updateVar :: Var -> [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 --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -13,43 +13,44 @@ -------------------------------------------------------------------------------- -import Control.Monad.Except (ExceptT (..), runExceptT, - throwError) -import Control.Monad.Trans (liftIO) -import qualified Data.Aeson.Extended as A -import qualified Data.Aeson.KeyMap as AKM -import Data.Bifunctor (first) -import Data.Maybe (fromMaybe) -import Data.Sequence.Extended (Seq) -import qualified Data.Sequence.Extended as Seq -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Traversable (for) -import qualified Data.Yaml as Yaml -import Patat.EncodingFallback (EncodingFallback) -import qualified Patat.EncodingFallback as EncodingFallback -import qualified Patat.Eval as Eval -import qualified Patat.Presentation.Comments as Comments +import Control.Monad (guard) +import Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.Trans (liftIO) +import qualified Data.Aeson.Extended as A +import qualified Data.Aeson.KeyMap as AKM +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) +import Data.Sequence.Extended (Seq) +import qualified Data.Sequence.Extended as Seq +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Traversable (for) +import qualified Data.Yaml as Yaml +import Patat.EncodingFallback (EncodingFallback) +import qualified Patat.EncodingFallback as EncodingFallback +import qualified Patat.Eval as Eval 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 qualified Patat.Presentation.SpeakerNotes as SpeakerNotes +import Patat.Presentation.Syntax +import Patat.Transition (parseTransitionSettings) +import Patat.Unique import Prelude -import qualified Skylighting as Skylighting -import System.Directory (XdgDirectory (XdgConfig), - doesFileExist, - getHomeDirectory, - getXdgDirectory) -import System.FilePath (splitFileName, takeExtension, - ()) -import qualified Text.Pandoc.Error as Pandoc -import qualified Text.Pandoc.Extended as Pandoc +import qualified Skylighting as Skylighting +import System.Directory (XdgDirectory (XdgConfig), + doesFileExist, + getHomeDirectory, + getXdgDirectory) +import System.FilePath (splitFileName, takeExtension, + ()) +import qualified Text.Pandoc.Error as Pandoc +import qualified Text.Pandoc.Extended as Pandoc -------------------------------------------------------------------------------- -readPresentation :: VarGen -> FilePath -> IO (Either String Presentation) -readPresentation varGen filePath = runExceptT $ do +readPresentation :: UniqueGen -> FilePath -> IO (Either String Presentation) +readPresentation uniqueGen filePath = runExceptT $ do -- We need to read the settings first. (enc, src) <- liftIO $ EncodingFallback.readFile filePath homeSettings <- ExceptT readHomeSettings @@ -72,8 +73,8 @@ Right x -> return x pres <- ExceptT $ pure $ - pandocToPresentation varGen filePath enc settings syntaxMap doc - pure $ Eval.parseEvalBlocks pres + pandocToPresentation uniqueGen filePath enc settings syntaxMap doc + pure $ fragmentPresentation $ Eval.parseEvalBlocks pres where ext = takeExtension filePath @@ -123,29 +124,29 @@ -------------------------------------------------------------------------------- pandocToPresentation - :: VarGen -> FilePath -> EncodingFallback -> PresentationSettings + :: UniqueGen -> FilePath -> EncodingFallback -> PresentationSettings -> Skylighting.SyntaxMap -> Pandoc.Pandoc -> Either String Presentation -pandocToPresentation pVarGen pFilePath pEncodingFallback pSettings pSyntaxMap +pandocToPresentation pUniqueGen pFilePath pEncodingFallback pSettings pSyntaxMap pandoc@(Pandoc.Pandoc meta _) = do let !pTitle = case Pandoc.docTitle meta of - [] -> [Pandoc.Str . T.pack . snd $ splitFileName pFilePath] - title -> title + [] -> [Str . T.pack . snd $ splitFileName pFilePath] + title -> fromPandocInlines title !pSlides = pandocToSlides pSettings pandoc !pBreadcrumbs = collectBreadcrumbs pSlides !pActiveFragment = (0, 0) - !pAuthor = concat (Pandoc.docAuthors meta) + !pAuthor = fromPandocInlines $ concat $ Pandoc.docAuthors meta !pEvalBlocks = mempty !pVars = mempty pSlideSettings <- Seq.traverseWithIndex - (\i -> - first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) . - Comments.parseSlideSettings . slideComment) + (\i slide -> case slideSettings slide of + Left err -> Left $ "on slide " ++ show (i + 1) ++ ": " ++ err + Right cfg -> pure cfg) pSlides pTransitionGens <- for pSlideSettings $ \slideSettings -> case psTransition (slideSettings <> pSettings) of Nothing -> pure Nothing Just ts -> Just <$> parseTransitionSettings ts - return Presentation {..} + return $ Presentation {..} -------------------------------------------------------------------------------- @@ -205,38 +206,28 @@ -------------------------------------------------------------------------------- pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> Seq.Seq Slide -pandocToSlides settings pandoc = - let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings) - unfragmented = splitSlides slideLevel pandoc - fragmented = map fragmentSlide unfragmented in - Seq.fromList fragmented - where - fragmentSlide slide = case slideContent slide of - TitleSlide _ _ -> slide - ContentSlide instrs0 -> - let instrs1 = fragmentInstructions fragmentSettings instrs0 in - slide {slideContent = ContentSlide instrs1} - - fragmentSettings = FragmentSettings - { fsIncrementalLists = fromMaybe False (psIncrementalLists settings) - } +pandocToSlides settings (Pandoc.Pandoc _meta pblocks) = + let blocks = fromPandocBlocks pblocks + slideLevel = fromMaybe (detectSlideLevel blocks) (psSlideLevel settings) + unfragmented = splitSlides slideLevel blocks in + Seq.fromList unfragmented -------------------------------------------------------------------------------- -- | Find level of header that starts slides. This is defined as the least -- header that occurs before a non-header in the blocks. -detectSlideLevel :: Pandoc.Pandoc -> Int -detectSlideLevel (Pandoc.Pandoc _meta blocks0) = - go 6 $ Comments.remove blocks0 +detectSlideLevel :: [Block] -> Int +detectSlideLevel blocks0 = + go 6 $ filter (not . isComment) blocks0 where - go level (Pandoc.Header n _ _ : x : xs) + go level (Header n _ _ : x : xs) | n < level && not (isHeader x) = go n xs | otherwise = go level (x:xs) go level (_ : xs) = go level xs go level [] = level - isHeader (Pandoc.Header _ _ _) = True - isHeader _ = False + isHeader (Header _ _ _) = True + isHeader _ = False -------------------------------------------------------------------------------- @@ -244,34 +235,43 @@ -- rules, we use those as slide delimiters. If there are no horizontal rules, -- we split using headers, determined by the slide level (see -- 'detectSlideLevel'). -splitSlides :: Int -> Pandoc.Pandoc -> [Slide] -splitSlides slideLevel (Pandoc.Pandoc _meta blocks0) - | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0 - | otherwise = splitAtHeaders [] blocks0 +splitSlides :: Int -> [Block] -> [Slide] +splitSlides slideLevel blocks0 + | any isHorizontalRule blocks0 = splitAtRules blocks0 + | otherwise = splitAtHeaders [] blocks0 where - mkContentSlide :: [Pandoc.Block] -> [Slide] - mkContentSlide bs0 = case Comments.partition bs0 of - (_, []) -> [] -- Never create empty slides - (sn, bs1) -> pure . Slide sn . ContentSlide $ - Instruction.fromList [Instruction.Append bs1] + mkContentSlide :: [Block] -> [Slide] + mkContentSlide bs0 = do + let bs1 = filter (not . isComment) bs0 + sns = SpeakerNotes.SpeakerNotes [s | SpeakerNote s <- bs0] + cfgs = concatCfgs [cfg | Config cfg <- bs0] + guard $ not $ null bs1 -- Never create empty slides + pure $ Slide sns cfgs $ ContentSlide bs1 - splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of + splitAtRules blocks = case break isHorizontalRule blocks of (xs, []) -> mkContentSlide xs (xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys splitAtHeaders acc [] = mkContentSlide (reverse acc) - splitAtHeaders acc (b@(Pandoc.Header i _ txt) : bs0) + splitAtHeaders acc (b@(Header i _ txt) : bs0) | i > slideLevel = splitAtHeaders (b : acc) bs0 | i == slideLevel = mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs0 | otherwise = - let (sn, bs1) = Comments.split bs0 in + let (cmnts, bs1) = break (not . isComment) bs0 + sns = SpeakerNotes.SpeakerNotes [s | SpeakerNote s <- cmnts] + cfgs = concatCfgs [cfg | Config cfg <- cmnts] in mkContentSlide (reverse acc) ++ - [Slide sn $ TitleSlide i txt] ++ + [Slide sns cfgs $ TitleSlide i txt] ++ splitAtHeaders [] bs1 splitAtHeaders acc (b : bs) = splitAtHeaders (b : acc) bs + + concatCfgs + :: [Either String PresentationSettings] + -> Either String PresentationSettings + concatCfgs = fmap mconcat . sequence -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation/Settings.hs b/lib/Patat/Presentation/Settings.hs --- a/lib/Patat/Presentation/Settings.hs +++ b/lib/Patat/Presentation/Settings.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -22,12 +23,14 @@ , SpeakerNotesSettings (..) , TransitionSettings (..) + + , parseSlideSettings ) where -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) -import Control.Monad (mplus) +import Control.Monad (mplus, unless) import qualified Data.Aeson.Extended as A import qualified Data.Aeson.TH.Extended as A import qualified Data.Foldable as Foldable @@ -62,7 +65,7 @@ , psSyntaxDefinitions :: !(Maybe [FilePath]) , psSpeakerNotes :: !(Maybe SpeakerNotesSettings) , psTransition :: !(Maybe TransitionSettings) - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -106,7 +109,7 @@ -------------------------------------------------------------------------------- -data Wrap = NoWrap | AutoWrap | WrapAt Int deriving (Show) +data Wrap = NoWrap | AutoWrap | WrapAt Int deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -117,7 +120,7 @@ -------------------------------------------------------------------------------- -data AutoOr a = Auto | NotAuto a deriving (Show) +data AutoOr a = Auto | NotAuto a deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -131,7 +134,7 @@ { msTop :: !(Maybe (AutoOr (A.FlexibleNum Int))) , msLeft :: !(Maybe (AutoOr (A.FlexibleNum Int))) , msRight :: !(Maybe (AutoOr (A.FlexibleNum Int))) - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -151,7 +154,7 @@ -------------------------------------------------------------------------------- newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} - deriving (Show) + deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -208,7 +211,7 @@ data ImageSettings = ImageSettings { isBackend :: !T.Text , isParams :: !A.Object - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -227,7 +230,7 @@ = EvalContainerCode | EvalContainerNone | EvalContainerInline - deriving (Show) + deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -246,10 +249,10 @@ data EvalSettings = EvalSettings { evalCommand :: !T.Text , evalReplace :: !Bool - , evalFragment :: !Bool + , evalReveal :: !Bool , evalContainer :: !EvalSettingsContainer , evalStderr :: !Bool - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -257,7 +260,7 @@ parseJSON = A.withObject "FromJSON EvalSettings" $ \o -> EvalSettings <$> o A..: "command" <*> o A..:? "replace" A..!= False - <*> o A..:? "fragment" A..!= True + <*> deprecated "fragment" "reveal" True o <*> deprecated "wrap" "container" EvalContainerCode o <*> o A..:? "stderr" A..!= True where @@ -276,14 +279,14 @@ -------------------------------------------------------------------------------- data SpeakerNotesSettings = SpeakerNotesSettings { snsFile :: !FilePath - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- data TransitionSettings = TransitionSettings { tsType :: !T.Text , tsParams :: !A.Object - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -296,3 +299,36 @@ $(A.deriveFromJSON A.dropPrefixOptions ''MarginSettings) $(A.deriveFromJSON A.dropPrefixOptions ''SpeakerNotesSettings) $(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) + + +-------------------------------------------------------------------------------- +data Setting where + Setting :: String -> (PresentationSettings -> Maybe a) -> Setting + + +-------------------------------------------------------------------------------- +unsupportedSlideSettings :: [Setting] +unsupportedSlideSettings = + [ Setting "incrementalLists" psIncrementalLists + , Setting "autoAdvanceDelay" psAutoAdvanceDelay + , Setting "slideLevel" psSlideLevel + , Setting "pandocExtensions" psPandocExtensions + , Setting "images" psImages + , Setting "eval" psEval + , Setting "speakerNotes" psSpeakerNotes + ] + + +-------------------------------------------------------------------------------- +parseSlideSettings :: PresentationSettings -> Either String PresentationSettings +parseSlideSettings settings = do + unless (null unsupported) $ Left $ + "the following settings are not supported in slide config blocks: " ++ + intercalate ", " unsupported + pure settings + where + unsupported = do + setting <- unsupportedSlideSettings + case setting of + Setting name f | Just _ <- f settings -> [name] + Setting _ _ -> [] diff --git a/lib/Patat/Presentation/SpeakerNotes.hs b/lib/Patat/Presentation/SpeakerNotes.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Presentation/SpeakerNotes.hs @@ -0,0 +1,61 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Patat.Presentation.SpeakerNotes + ( SpeakerNotes (..) + , toText + + , Handle + , withHandle + , write + + , parseSlideSettings + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (bracket) +import Control.Monad (when) +import qualified Data.IORef as IORef +import Data.List (intersperse) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Patat.EncodingFallback (EncodingFallback) +import qualified Patat.EncodingFallback as EncodingFallback +import Patat.Presentation.Settings +import System.Directory (removeFile) +import qualified System.IO as IO + + +-------------------------------------------------------------------------------- +newtype SpeakerNotes = SpeakerNotes [T.Text] + deriving (Eq, Monoid, Semigroup, Show) + + +-------------------------------------------------------------------------------- +toText :: SpeakerNotes -> T.Text +toText (SpeakerNotes sn) = T.unlines $ intersperse mempty sn + + +-------------------------------------------------------------------------------- +data Handle = Handle + { hSettings :: !SpeakerNotesSettings + , hActive :: !(IORef.IORef SpeakerNotes) + } + + +-------------------------------------------------------------------------------- +withHandle + :: SpeakerNotesSettings -> (Handle -> IO a) -> IO a +withHandle settings = bracket + (Handle settings <$> IORef.newIORef mempty) + (\_ -> removeFile (snsFile settings)) + + +-------------------------------------------------------------------------------- +write + :: Handle -> EncodingFallback -> SpeakerNotes -> IO () +write h encodingFallback sn = do + change <- IORef.atomicModifyIORef' (hActive h) $ \old -> (sn, old /= sn) + when change $ IO.withFile (snsFile $ hSettings h) IO.WriteMode $ \ioh -> + EncodingFallback.withHandle ioh encodingFallback $ + T.hPutStr ioh $ toText sn diff --git a/lib/Patat/Presentation/Syntax.hs b/lib/Patat/Presentation/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Presentation/Syntax.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Patat.Presentation.Syntax + ( Block (..) + , Inline (..) + + , dftBlocks + , dftInlines + + , fromPandocBlocks + , fromPandocInlines + + , isHorizontalRule + , isComment + + , Var (..) + , variables + + , RevealID (..) + , blocksRevealSteps + , blocksRevealStep + , blocksRevealLastStep + , blocksRevealOrder + , blocksReveal + , RevealState + , revealToBlocks + + , RevealWrapper (..) + , revealWrapper + , RevealSequence (..) + ) where + +import Control.Monad.Identity (runIdentity) +import Control.Monad.State (State, execState, modify) +import Control.Monad.Writer (Writer, execWriter, tell) +import Data.Hashable (Hashable) +import qualified Data.HashSet as HS +import Data.List (foldl') +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Traversable (for) +import qualified Data.Yaml as Yaml +import Patat.Presentation.Settings (PresentationSettings) +import Patat.Unique +import qualified Text.Pandoc as Pandoc +import qualified Text.Pandoc.Writers.Shared as Pandoc + +-- | This is similar to 'Pandoc.Block'. Having our own datatype has some +-- advantages: +-- +-- * We can extend it with slide-specific data (eval, reveals) +-- * We can remove stuff we don't care about +-- * We can parse attributes and move them to haskell datatypes +-- * This conversion can happen in a single parsing phase +-- * We can catch backwards-incompatible pandoc changes in this module +-- +-- We try to follow the naming conventions from Pandoc as much as possible. +data Block + = Plain ![Inline] + | Para ![Inline] + | LineBlock ![[Inline]] + | CodeBlock !Pandoc.Attr !T.Text + | RawBlock !Pandoc.Format !T.Text + | BlockQuote ![Block] + | OrderedList !Pandoc.ListAttributes ![[Block]] + | BulletList ![[Block]] + | DefinitionList ![([Inline], [[Block]])] + | Header Int !Pandoc.Attr ![Inline] + | HorizontalRule + | Table ![Inline] ![Pandoc.Alignment] ![[Block]] ![[[Block]]] + | Figure !Pandoc.Attr ![Block] + | Div !Pandoc.Attr ![Block] + -- Our own extensions: + | Reveal !RevealWrapper !(RevealSequence [Block]) + | VarBlock !Var + | SpeakerNote !T.Text + | Config !(Either String PresentationSettings) + deriving (Eq, Show) + +-- | See comment on 'Block'. +data Inline + = Str !T.Text + | Emph ![Inline] + | Underline ![Inline] + | Strong ![Inline] + | Strikeout ![Inline] + | Superscript ![Inline] + | Subscript ![Inline] + | SmallCaps ![Inline] + | Quoted !Pandoc.QuoteType ![Inline] + | Cite ![Pandoc.Citation] ![Inline] + | Code !Pandoc.Attr !T.Text + | Space + | SoftBreak + | LineBreak + | Math !Pandoc.MathType !T.Text + | RawInline !Pandoc.Format !T.Text + | Link !Pandoc.Attr ![Inline] !Pandoc.Target + | Image !Pandoc.Attr ![Inline] !Pandoc.Target + | Note ![Block] + | Span !Pandoc.Attr ![Inline] + deriving (Eq, Show) + +-- | Depth-First Traversal of blocks (and inlines). +dftBlocks + :: forall m. Monad m + => (Block -> m [Block]) + -> (Inline -> m [Inline]) + -> [Block] -> m [Block] +dftBlocks fb fi = blocks + where + blocks :: [Block] -> m [Block] + blocks = fmap concat . traverse block + + inlines :: [Inline] -> m [Inline] + inlines = dftInlines fb fi + + block :: Block -> m [Block] + block = (>>= fb) . \case + Plain xs -> Plain <$> inlines xs + Para xs -> Para <$> inlines xs + LineBlock xss -> LineBlock <$> traverse inlines xss + b@(CodeBlock _attr _txt) -> pure b + b@(RawBlock _fmt _txt) -> pure b + BlockQuote xs -> BlockQuote <$> blocks xs + OrderedList attr xss -> OrderedList attr <$> traverse blocks xss + BulletList xss ->BulletList <$> traverse blocks xss + DefinitionList xss -> DefinitionList <$> for xss + (\(term, definition) -> (,) + <$> inlines term + <*> traverse blocks definition) + Header lvl attr xs -> Header lvl attr <$> inlines xs + b@HorizontalRule -> pure b + Table cptn aligns thead trows -> Table + <$> inlines cptn + <*> pure aligns + <*> traverse blocks thead + <*> traverse (traverse blocks) trows + Figure attr xs -> Figure attr <$> blocks xs + Div attr xs -> Div attr <$> blocks xs + Reveal w revealer-> Reveal w <$> traverse blocks revealer + b@(VarBlock _var) -> pure b + b@(SpeakerNote _txt) -> pure b + b@(Config _cfg) -> pure b + +-- | Depth-First Traversal of inlines (and blocks). +dftInlines + :: forall m. Monad m + => (Block -> m [Block]) + -> (Inline -> m [Inline]) + -> [Inline] -> m [Inline] +dftInlines fb fi = inlines + where + inlines :: [Inline] -> m [Inline] + inlines = fmap concat . traverse inline + + inline :: Inline -> m [Inline] + inline = (>>= fi) . \case + i@(Str _txt) -> pure i + Emph xs -> Emph <$> inlines xs + Underline xs -> Underline <$> inlines xs + Strong xs -> Strong <$> inlines xs + Strikeout xs -> Strikeout <$> inlines xs + Superscript xs -> Superscript <$> inlines xs + Subscript xs -> Subscript <$> inlines xs + SmallCaps xs -> SmallCaps <$> inlines xs + Quoted ty xs -> Quoted ty <$> inlines xs + Cite c xs -> Cite c <$> inlines xs + i@(Code _attr _txt) -> pure i + i@Space -> pure i + i@SoftBreak -> pure i + i@LineBreak -> pure i + i@(Math _ty _txt) -> pure i + i@(RawInline _fmt _txt) -> pure i + Link attr xs tgt -> Link attr <$> inlines xs <*> pure tgt + Image attr xs tgt -> Image attr <$> inlines xs <*> pure tgt + Note blocks -> Note <$> dftBlocks fb fi blocks + Span attr xs -> Span attr . concat <$> traverse inline xs + +fromPandocBlocks :: [Pandoc.Block] -> [Block] +fromPandocBlocks = concatMap fromPandocBlock + +fromPandocBlock :: Pandoc.Block -> [Block] +fromPandocBlock (Pandoc.Plain xs) = [Plain (fromPandocInlines xs)] +fromPandocBlock (Pandoc.Para xs) = [Para (fromPandocInlines xs)] +fromPandocBlock (Pandoc.LineBlock xs) = + [LineBlock (map fromPandocInlines xs)] +fromPandocBlock (Pandoc.CodeBlock attrs body) = [CodeBlock attrs body] +fromPandocBlock (Pandoc.RawBlock fmt body) + -- Parse config blocks. + | fmt == "html" + , Just t1 <- T.stripPrefix "" t1 = pure $ Config $ + case Yaml.decodeEither' (T.encodeUtf8 t2) of + Left err -> Left (show err) + Right obj -> Right obj + -- Parse other comments. + | Just t1 <- T.stripPrefix "" t1 = pure $ SpeakerNote $ T.strip t2 + -- Other raw blocks, leave as-is. + | otherwise = [RawBlock fmt body] +fromPandocBlock (Pandoc.BlockQuote blocks) = + [BlockQuote $ fromPandocBlocks blocks] +fromPandocBlock (Pandoc.OrderedList attrs items) = + [OrderedList attrs $ map fromPandocBlocks items] +fromPandocBlock (Pandoc.BulletList items) = + [BulletList $ map fromPandocBlocks items] +fromPandocBlock (Pandoc.DefinitionList items) = pure $ DefinitionList $ do + (inlines, blockss) <- items + pure (fromPandocInlines inlines, map (fromPandocBlocks) blockss) +fromPandocBlock (Pandoc.Header lvl attrs inlines) = + [Header lvl attrs (fromPandocInlines inlines)] +fromPandocBlock Pandoc.HorizontalRule = [HorizontalRule] +fromPandocBlock (Pandoc.Table _ cptn specs thead tbodies tfoot) = pure $ Table + (fromPandocInlines cptn') + aligns + (map (fromPandocBlocks) headers) + (map (map fromPandocBlocks) rows) + where + (cptn', aligns, _, headers, rows) = Pandoc.toLegacyTable + cptn specs thead tbodies tfoot + +fromPandocBlock (Pandoc.Figure attrs _caption blocks) = + [Figure attrs $ fromPandocBlocks blocks] +fromPandocBlock (Pandoc.Div attrs blocks) = + [Div attrs $ fromPandocBlocks blocks] + +fromPandocInlines :: [Pandoc.Inline] -> [Inline] +fromPandocInlines = concatMap fromPandocInline + +fromPandocInline :: Pandoc.Inline -> [Inline] +fromPandocInline inline = case inline of + Pandoc.Str txt -> pure $ Str txt + Pandoc.Emph xs -> pure $ Emph (fromPandocInlines xs) + Pandoc.Underline xs -> pure $ Underline (fromPandocInlines xs) + Pandoc.Strong xs -> pure $ Strong (fromPandocInlines xs) + Pandoc.Strikeout xs -> pure $ Strikeout (fromPandocInlines xs) + Pandoc.Superscript xs -> pure $ Superscript (fromPandocInlines xs) + Pandoc.Subscript xs -> pure $ Subscript (fromPandocInlines xs) + Pandoc.SmallCaps xs -> pure $ SmallCaps (fromPandocInlines xs) + Pandoc.Quoted ty xs -> pure $ Quoted ty (fromPandocInlines xs) + Pandoc.Cite c xs -> pure $ Cite c (fromPandocInlines xs) + Pandoc.Code attr txt -> pure $ Code attr txt + Pandoc.Space -> pure $ Space + Pandoc.SoftBreak -> pure $ SoftBreak + Pandoc.LineBreak -> pure $ LineBreak + Pandoc.Math ty txt -> pure $ Math ty txt + Pandoc.RawInline fmt txt -> pure $ RawInline fmt txt + Pandoc.Link attr xs tgt -> pure $ Link attr (fromPandocInlines xs) tgt + Pandoc.Image attr xs tgt -> pure $ Image attr (fromPandocInlines xs) tgt + Pandoc.Note xs -> pure $ Note (fromPandocBlocks xs) + Pandoc.Span attr xs -> pure $ Span attr (fromPandocInlines xs) + +isHorizontalRule :: Block -> Bool +isHorizontalRule HorizontalRule = True +isHorizontalRule _ = False + +isComment :: Block -> Bool +isComment (SpeakerNote _) = True +isComment (Config _) = True +isComment _ = False + +-- | 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 Unique deriving (Hashable, Eq, Ord, Show) + +-- | Finds all variables that appear in some content. +variables :: [Block] -> HS.HashSet Var +variables = execWriter . dftBlocks visit (pure . pure) + where + visit :: Block -> Writer (HS.HashSet Var) [Block] + visit b = do + case b of + VarBlock var -> tell $ HS.singleton var + _ -> pure () + pure [b] + +-- | A counter is used to change state in a slide. As counters increment, +-- content may deterministically show or hide. +newtype RevealID = RevealID Unique deriving (Eq, Ord, Show) + +-- | A reveal sequence stores content which can be hidden or shown depending on +-- a counter state. +-- +-- The easiest example to think about is a bullet list which appears +-- incrmentally on a slide. Initially, the counter state is 0. As it is +-- incremented (the user goes to the next fragment in the slide), more list +-- items become visible. +data RevealSequence a = RevealSequence + { -- The ID used for this sequence. + rsID :: RevealID + , -- These reveals should be advanced in this order. + -- Reveal IDs will be included multiple times if needed. + -- + -- This should (only) contain the ID of this counter, and IDs of counters + -- nested inside the children fields. + rsOrder :: [RevealID] + , -- For each piece of content in this sequence, we store a set of ints. + -- When the current counter state is included in this set, the item is + -- visible. + rsVisible :: [(S.Set Int, a)] + } deriving (Foldable, Functor, Eq, Show, Traversable) + +-- | This determines how we construct content based on the visible items. +-- This could also be represented as `[[Block]] -> [Block]` but then we lose +-- the convenient Eq and Show instances. +data RevealWrapper + = ConcatWrapper + | BulletListWrapper + | OrderedListWrapper Pandoc.ListAttributes + deriving (Eq, Show) + +revealWrapper :: RevealWrapper -> [[Block]] -> [Block] +revealWrapper ConcatWrapper = concat +revealWrapper BulletListWrapper = pure . BulletList +revealWrapper (OrderedListWrapper attr) = pure . OrderedList attr + +-- | Number of reveal steps in some blocks. +blocksRevealSteps :: [Block] -> Int +blocksRevealSteps = succ . length . blocksRevealOrder + +-- | Construct the reveal state for a specific step. +blocksRevealStep :: Int -> [Block] -> RevealState +blocksRevealStep fidx = makeRevealState . take fidx . blocksRevealOrder + +-- | Construct the final reveal state. +blocksRevealLastStep :: [Block] -> RevealState +blocksRevealLastStep = makeRevealState . blocksRevealOrder + +-- | This does a deep traversal of some blocks, and returns all reveals that +-- should be advanced in-order. +blocksRevealOrder :: [Block] -> [RevealID] +blocksRevealOrder blocks = concat $ + execState (dftBlocks visit (pure . pure) blocks) [] + where + -- We store a [[RevealID]] state, where each list represents the triggers + -- necessary for a single reveal block. + visit :: Block -> State [[RevealID]] [Block] + visit (Reveal w rs) = do + modify $ merge rs + pure [Reveal w rs] + visit block = pure [block] + + -- When we encounter a new reveal, we want to merge this into our + -- [[RevealID]] state. However, we need to ensure to remove any children + -- of that reveal block that were already in this list. + merge :: RevealSequence [Block] -> [[RevealID]] -> [[RevealID]] + merge (RevealSequence fid triggers _) known + | any (fid `elem`) known = known + | otherwise = + filter (not . any (`elem` triggers)) known ++ [triggers] + +-- | Stores the state of several counters. +type RevealState = M.Map RevealID Int + +-- | Convert a list of counters that need to be triggered to the final state. +makeRevealState :: [RevealID] -> RevealState +makeRevealState = foldl' (\acc x -> M.insertWith (+) x 1 acc) M.empty + +-- | Render a reveal by applying its constructor to what is visible. +revealToBlocks + :: RevealState -> RevealWrapper -> RevealSequence [Block] -> [Block] +revealToBlocks revealState rw (RevealSequence cid _ sections) = revealWrapper rw + [s | (activation, s) <- sections, counter `S.member` activation] + where + counter = fromMaybe 0 $ M.lookup cid revealState + +-- | Apply `revealToBlocks` recursively at each position, removing reveals +-- in favor of their currently visible content. +blocksReveal :: RevealState -> [Block] -> [Block] +blocksReveal revealState = runIdentity . dftBlocks visit (pure . pure) + where + visit (Reveal w rs) = pure $ revealToBlocks revealState w rs + visit block = pure [block] diff --git a/lib/Patat/Theme.hs b/lib/Patat/Theme.hs --- a/lib/Patat/Theme.hs +++ b/lib/Patat/Theme.hs @@ -57,7 +57,7 @@ , themeImageText :: !(Maybe Style) , themeImageTarget :: !(Maybe Style) , themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting) - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -138,7 +138,7 @@ -------------------------------------------------------------------------------- newtype Style = Style {unStyle :: [Ansi.SGR]} - deriving (Monoid, Semigroup, Show) + deriving (Eq, Monoid, Semigroup, Show) -------------------------------------------------------------------------------- @@ -241,7 +241,7 @@ -------------------------------------------------------------------------------- newtype SyntaxHighlighting = SyntaxHighlighting { unSyntaxHighlighting :: M.Map String Style - } deriving (Monoid, Semigroup, Show, A.ToJSON) + } deriving (Eq, Monoid, Semigroup, Show, A.ToJSON) -------------------------------------------------------------------------------- diff --git a/lib/Patat/Unique.hs b/lib/Patat/Unique.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Unique.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Patat.Unique + ( Unique + , UniqueGen + , zeroUniqueGen + , freshUnique + ) where + +import Data.Hashable (Hashable) + +-- | Can be used as a unique identifier. +newtype Unique = Unique Int deriving (Hashable, Eq, Ord, Show) + +-- | Used to generate fresh variables. +newtype UniqueGen = UniqueGen Int deriving (Show) + +zeroUniqueGen :: UniqueGen +zeroUniqueGen = UniqueGen 0 + +freshUnique :: UniqueGen -> (Unique, UniqueGen) +freshUnique (UniqueGen x) = (Unique x, UniqueGen (x + 1)) diff --git a/lib/Text/Pandoc/Extended.hs b/lib/Text/Pandoc/Extended.hs --- a/lib/Text/Pandoc/Extended.hs +++ b/lib/Text/Pandoc/Extended.hs @@ -2,35 +2,15 @@ {-# LANGUAGE LambdaCase #-} module Text.Pandoc.Extended ( module Text.Pandoc - - , plainToPara - , newlineToSpace - , readPlainText ) where -------------------------------------------------------------------------------- -import Data.Char (isSpace) -import Data.Data.Extended (grecT) -import qualified Data.Text as T +import Data.Char (isSpace) +import qualified Data.Text as T import Prelude import Text.Pandoc - - --------------------------------------------------------------------------------- -plainToPara :: [Block] -> [Block] -plainToPara = map $ \case - Plain inlines -> Para inlines - block -> block - - --------------------------------------------------------------------------------- -newlineToSpace :: [Inline] -> [Inline] -newlineToSpace = grecT $ \case - SoftBreak -> Space - LineBreak -> Space - inline -> inline -------------------------------------------------------------------------------- diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -1,5 +1,5 @@ Name: patat -Version: 0.13.0.0 +Version: 0.14.0.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc. License: GPL-2 @@ -46,7 +46,7 @@ hashable >= 1.4 && < 1.5, mtl >= 2.2 && < 2.4, optparse-applicative >= 0.16 && < 0.19, - pandoc >= 3.1 && < 3.3, + pandoc >= 3.1 && < 3.6, pandoc-types >= 1.23 && < 1.24, process >= 1.6 && < 1.7, random >= 1.2 && < 1.3, @@ -80,17 +80,17 @@ Patat.Images.W3m Patat.Main Patat.Presentation - Patat.Presentation.Comments Patat.Presentation.Display Patat.Presentation.Display.CodeBlock Patat.Presentation.Display.Internal Patat.Presentation.Display.Table Patat.Presentation.Fragment - Patat.Presentation.Instruction Patat.Presentation.Interactive Patat.Presentation.Internal Patat.Presentation.Read Patat.Presentation.Settings + Patat.Presentation.SpeakerNotes + Patat.Presentation.Syntax Patat.PrettyPrint Patat.PrettyPrint.Internal Patat.PrettyPrint.Matrix @@ -101,13 +101,13 @@ Patat.Transition.Dissolve Patat.Transition.Matrix Patat.Transition.SlideLeft + Patat.Unique Other-modules: Control.Concurrent.Chan.Extended Data.Aeson.Extended Data.Aeson.TH.Extended Data.Char.WCWidth.Extended - Data.Data.Extended Data.Sequence.Extended Paths_patat Text.Pandoc.Extended @@ -135,7 +135,7 @@ containers >= 0.6 && < 0.8, doctemplates >= 0.8 && < 0.12, mtl >= 2.2 && < 2.4, - pandoc >= 3.1 && < 3.3, + pandoc >= 3.1 && < 3.6, text >= 1.2 && < 2.2, time >= 1.6 && < 1.13 @@ -156,7 +156,7 @@ ansi-terminal >= 0.6 && < 1.1, base >= 4.8 && < 5, directory >= 1.2 && < 1.4, - pandoc >= 3.1 && < 3.3, + pandoc >= 3.1 && < 3.6, tasty >= 1.2 && < 1.6, tasty-hunit >= 0.10 && < 0.11, tasty-quickcheck >= 0.10 && < 0.11, diff --git a/tests/haskell/Patat/Presentation/Read/Tests.hs b/tests/haskell/Patat/Presentation/Read/Tests.hs --- a/tests/haskell/Patat/Presentation/Read/Tests.hs +++ b/tests/haskell/Patat/Presentation/Read/Tests.hs @@ -6,9 +6,9 @@ -------------------------------------------------------------------------------- import Patat.Presentation.Read -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as Tasty -import qualified Text.Pandoc as Pandoc +import Patat.Presentation.Syntax +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty -------------------------------------------------------------------------------- @@ -46,21 +46,21 @@ testDetectSlideLevel :: Tasty.TestTree testDetectSlideLevel = Tasty.testGroup "detectSlideLevel" [ Tasty.testCase "01" $ - (Tasty.@=?) 1 $ detectSlideLevel $ Pandoc.Pandoc mempty - [ Pandoc.Header 1 mempty [Pandoc.Str "Intro"] - , Pandoc.Para [Pandoc.Str "Hi"] + (Tasty.@=?) 1 $ detectSlideLevel + [ Header 1 mempty [Str "Intro"] + , Para [Str "Hi"] ] , Tasty.testCase "02" $ - (Tasty.@=?) 2 $ detectSlideLevel $ Pandoc.Pandoc mempty - [ Pandoc.Header 1 mempty [Pandoc.Str "Intro"] - , Pandoc.Header 2 mempty [Pandoc.Str "Detail"] - , Pandoc.Para [Pandoc.Str "Hi"] + (Tasty.@=?) 2 $ detectSlideLevel + [ Header 1 mempty [Str "Intro"] + , Header 2 mempty [Str "Detail"] + , Para [Str "Hi"] ] , Tasty.testCase "03" $ - (Tasty.@=?) 2 $ detectSlideLevel $ Pandoc.Pandoc mempty - [ Pandoc.Header 1 mempty [Pandoc.Str "Intro"] - , Pandoc.RawBlock "html" "" - , Pandoc.Header 2 mempty [Pandoc.Str "Detail"] - , Pandoc.Para [Pandoc.Str "Hi"] + (Tasty.@=?) 2 $ detectSlideLevel + [ Header 1 mempty [Str "Intro"] + , SpeakerNote "Some speaker note" + , Header 2 mempty [Str "Detail"] + , Para [Str "Hi"] ] ]