From 2567bc6b4941f85df5cf5aa87896f83645f0eecc Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 8 Sep 2020 15:15:03 +0200 Subject: [PATCH] Refactor implementation of fragments. Fragments deal with how content is shown piece by piece. For example, if we have the slide: Foo . . . Bar There are two fragments. First, only `Foo` is visible. When the user goes to the next fragment, `Foo` and `Bar` are both visible. The first implementation of fragments in patat would compute the state of all the visible items. In this case, that would be: 1. `[Foo]` 2. `[Foo, Bar]` This does not work elegantly if you want another pass to add further fragments: you now need to split `Foo` in multiple places (and the thunk is no longer shared). This PR refactors this to use "instructions" over the slide content. For the example, these instructions would be: 1. `Append [Foo]` 2. `Pause` 3. `Append [Bar]` The `Pause`s are explicit, and indicate how many fragments are present. There are more constructors, for manipulation of lists which is necessary if nested lists are shown incrementally. This all for allows much nicer manipulation of the fragments, which in turn is useful for #52. --- lib/Patat/Presentation/Display.hs | 17 ++-- lib/Patat/Presentation/Fragment.hs | 132 +++++++++---------------- lib/Patat/Presentation/Instruction.hs | 93 +++++++++++++++++ lib/Patat/Presentation/Internal.hs | 46 +++++---- lib/Patat/Presentation/Read.hs | 43 ++++---- patat.cabal | 1 + tests/golden/outputs/fragments.md.dump | 3 - 7 files changed, 193 insertions(+), 142 deletions(-) create mode 100644 lib/Patat/Presentation/Instruction.hs diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs index 15faeb8..da73f97 100644 --- a/lib/Patat/Presentation/Display.hs +++ b/lib/Patat/Presentation/Display.hs @@ -21,6 +21,7 @@ import Patat.Cleanup import qualified Patat.Images as Images import Patat.Presentation.Display.CodeBlock import Patat.Presentation.Display.Table +import qualified Patat.Presentation.Instruction as Instruction import Patat.Presentation.Internal import Patat.PrettyPrint ((<$$>), (<+>)) import qualified Patat.PrettyPrint as PP @@ -167,9 +168,10 @@ dumpPresentation pres = return $ case slide of TitleSlide l inlines -> "~~~title" <$$> prettyBlock theme (Pandoc.Header l Pandoc.nullAttr inlines) - ContentSlide fragments -> PP.vcat $ L.intersperse "~~~frag" $ do - fragment <- fragments - return $ prettyFragment theme fragment + ContentSlide instrs -> PP.vcat $ L.intersperse "~~~frag" $ do + n <- [0 .. Instruction.numFragments instrs - 1] + return $ prettyFragment theme $ + Instruction.renderFragment n instrs -------------------------------------------------------------------------------- @@ -183,11 +185,12 @@ formatWith ps = wrap . indent spaces = PP.NotTrimmable $ PP.spaces marginLeft indent = PP.indent spaces spaces + -------------------------------------------------------------------------------- prettyFragment :: Theme -> Fragment -> PP.Doc -prettyFragment theme fragment@(Fragment blocks) = +prettyFragment theme (Fragment blocks) = prettyBlocks theme blocks <> - case prettyReferences theme fragment of + case prettyReferences theme blocks of [] -> mempty refs -> PP.hardline <> PP.vcat refs @@ -356,9 +359,9 @@ prettyInlines theme = mconcat . map (prettyInline theme) -------------------------------------------------------------------------------- -prettyReferences :: Theme -> Fragment -> [PP.Doc] +prettyReferences :: Theme -> [Pandoc.Block] -> [PP.Doc] prettyReferences theme@Theme {..} = - map prettyReference . getReferences . unFragment + map prettyReference . getReferences where getReferences :: [Pandoc.Block] -> [Pandoc.Inline] getReferences = filter isReferenceLink . grecQ diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs index 4688c69..41c088c 100644 --- a/lib/Patat/Presentation/Fragment.hs +++ b/lib/Patat/Presentation/Fragment.hs @@ -7,53 +7,38 @@ {-# LANGUAGE OverloadedStrings #-} module Patat.Presentation.Fragment ( FragmentSettings (..) + + , fragmentInstructions , fragmentBlocks , fragmentBlock ) where -import Data.List (foldl', intersperse) -import Data.Maybe (fromMaybe) +import Data.List (intersperse, intercalate) +import Patat.Presentation.Instruction import Prelude -import qualified Text.Pandoc as Pandoc +import qualified Text.Pandoc as Pandoc data FragmentSettings = FragmentSettings { fsIncrementalLists :: !Bool } deriving (Show) --- fragmentBlocks :: [Pandoc.Block] -> [[Pandoc.Block]] --- fragmentBlocks = NonEmpty.toList . joinFragmentedBlocks . map fragmentBlock -fragmentBlocks :: FragmentSettings -> [Pandoc.Block] -> [[Pandoc.Block]] -fragmentBlocks fs blocks0 = - case joinFragmentedBlocks (map (fragmentBlock fs) blocks0) of - Unfragmented bs -> [bs] - Fragmented xs bs -> map (fromMaybe []) xs ++ [fromMaybe [] bs] +fragmentInstructions + :: FragmentSettings + -> Instructions Pandoc.Block -> Instructions Pandoc.Block +fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList + where + fragmentInstruction Pause = [Pause] + fragmentInstruction (Append xs) = fragmentBlocks fs xs + fragmentInstruction (ModifyLast f) = map ModifyLast $ fragmentInstruction f --- | This is all the ways we can "present" a block, after splitting in --- fragments. --- --- In the simplest (and most common case) a block can only be presented in a --- single way ('Unfragmented'). --- --- Alternatively, we might want to show different (partial) versions of the --- block first before showing the final complete one. These partial or complete --- versions can be empty, hence the 'Maybe'. --- --- For example, imagine that we display the following bullet list incrementally: --- --- > [1, 2, 3] --- --- Then we would get something like: --- --- > Fragmented [Nothing, Just [1], Just [1, 2]] (Just [1, 2, 3]) -data Fragmented a - = Unfragmented a - | Fragmented [Maybe a] (Maybe a) - deriving (Functor, Foldable, Show, Traversable) +fragmentBlocks + :: FragmentSettings -> [Pandoc.Block] -> [Instruction Pandoc.Block] +fragmentBlocks = concatMap . fragmentBlock -fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block +fragmentBlock :: FragmentSettings -> Pandoc.Block -> [Instruction Pandoc.Block] fragmentBlock _fs block@(Pandoc.Para inlines) - | inlines == threeDots = Fragmented [Nothing] Nothing - | otherwise = Unfragmented block + | inlines == threeDots = [Pause] + | otherwise = [Append [block]] where threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".") @@ -69,65 +54,38 @@ fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) = fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) = fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0 -fragmentBlock _ block@(Pandoc.BlockQuote _) = Unfragmented block - -fragmentBlock _ block@(Pandoc.Header _ _ _) = Unfragmented block -fragmentBlock _ block@(Pandoc.Plain _) = Unfragmented block -fragmentBlock _ block@(Pandoc.CodeBlock _ _) = Unfragmented block -fragmentBlock _ block@(Pandoc.RawBlock _ _) = Unfragmented block -fragmentBlock _ block@(Pandoc.DefinitionList _) = Unfragmented block -fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = Unfragmented block -fragmentBlock _ block@(Pandoc.Div _ _) = Unfragmented block -fragmentBlock _ block@Pandoc.HorizontalRule = Unfragmented block -fragmentBlock _ block@Pandoc.Null = Unfragmented block - -#if MIN_VERSION_pandoc(1,18,0) -fragmentBlock _ block@(Pandoc.LineBlock _) = Unfragmented block -#endif - -joinFragmentedBlocks :: [Fragmented block] -> Fragmented [block] -joinFragmentedBlocks = - foldl' append (Unfragmented []) - where - append (Unfragmented xs) (Unfragmented y) = - Unfragmented (xs ++ [y]) +fragmentBlock _ block@(Pandoc.BlockQuote _) = [Append [block]] - append (Fragmented xs x) (Unfragmented y) = - Fragmented xs (appendMaybe x (Just y)) - - append (Unfragmented x) (Fragmented ys y) = - Fragmented - [appendMaybe (Just x) y' | y' <- ys] - (appendMaybe (Just x) y) - - append (Fragmented xs x) (Fragmented ys y) = - Fragmented - (xs ++ [appendMaybe x y' | y' <- ys]) - (appendMaybe x y) - - appendMaybe :: Maybe [a] -> Maybe a -> Maybe [a] - appendMaybe Nothing Nothing = Nothing - appendMaybe Nothing (Just x) = Just [x] - appendMaybe (Just xs) Nothing = Just xs - appendMaybe (Just xs) (Just x) = Just (xs ++ [x]) +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.Null = [Append [block]] +fragmentBlock _ block@(Pandoc.LineBlock _) = [Append [block]] fragmentList :: FragmentSettings -- ^ Global settings -> Bool -- ^ Fragment THIS list? -> ([[Pandoc.Block]] -> Pandoc.Block) -- ^ List constructor -> [[Pandoc.Block]] -- ^ List items - -> Fragmented Pandoc.Block -- ^ Resulting list -fragmentList fs fragmentThisList constructor blocks0 = - fmap constructor fragmented + -> [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) where -- The fragmented list per list item. - items :: [Fragmented [Pandoc.Block]] - items = map (joinFragmentedBlocks . map (fragmentBlock fs)) blocks0 - - fragmented :: Fragmented [[Pandoc.Block]] - fragmented = joinFragmentedBlocks $ - map (if fragmentThisList then insertPause else id) items - - insertPause :: Fragmented a -> Fragmented a - insertPause (Unfragmented x) = Fragmented [Nothing] (Just x) - insertPause (Fragmented xs x) = Fragmented (Nothing : xs) x + 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) diff --git a/lib/Patat/Presentation/Instruction.hs b/lib/Patat/Presentation/Instruction.hs new file mode 100644 index 0000000..47dc22d --- /dev/null +++ b/lib/Patat/Presentation/Instruction.hs @@ -0,0 +1,93 @@ +-------------------------------------------------------------------------------- +-- | 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. +module Patat.Presentation.Instruction + ( Instructions + , fromList + , toList + + , Instruction (..) + , numFragments + + , Fragment (..) + , renderFragment + ) where + +import qualified Text.Pandoc as Pandoc + +newtype Instructions a = Instructions [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 + +data Instruction a + -- Pause. + = Pause + -- Append items. + | Append [a] + -- Modify the last block with the provided instruction. + | ModifyLast (Instruction a) + deriving (Show) + +isPause :: Instruction a -> Bool +isPause Pause = True +isPause (Append _) = False +isPause (ModifyLast i) = isPause i + +numPauses :: Instructions a -> Int +numPauses (Instructions xs) = length $ filter isPause xs + +numFragments :: Instructions a -> Int +numFragments = succ . numPauses + +newtype Fragment = Fragment [Pandoc.Block] deriving (Show) + +renderFragment :: Int -> Instructions Pandoc.Block -> Fragment +renderFragment = \n (Instructions instrs) -> Fragment $ go [] n instrs + where + go acc _ [] = acc + go acc n (Pause : instrs) = if n <= 0 then acc else go acc (n - 1) instrs + go acc n (instr : instrs) = go (goBlocks instr acc) n instrs + +goBlocks :: Instruction Pandoc.Block -> [Pandoc.Block] -> [Pandoc.Block] +goBlocks Pause xs = xs +goBlocks (Append ys) xs = xs ++ ys +goBlocks (ModifyLast f) xs + | null xs = xs -- Shouldn't happen unless instructions are malformed. + | otherwise = modifyLast (goBlock f) xs + +goBlock :: 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 (ModifyLast f) block = case block of + -- We can only modify the last content of a few specific block types for + -- now. + Pandoc.BulletList xs -> Pandoc.BulletList $ modifyLast (goBlocks f) xs + Pandoc.OrderedList attr xs -> + Pandoc.OrderedList attr $ modifyLast (goBlocks f) xs + _ -> block + +modifyLast :: (a -> a) -> [a] -> [a] +modifyLast f (x : y : zs) = x : modifyLast f (y : zs) +modifyLast f (x : []) = [f x] +modifyLast _ [] = [] diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs index 77bee62..b50e871 100644 --- a/lib/Patat/Presentation/Internal.hs +++ b/lib/Patat/Presentation/Internal.hs @@ -17,7 +17,7 @@ module Patat.Presentation.Internal , ImageSettings (..) , Slide (..) - , Fragment (..) + , Instruction.Fragment (..) , Index , getSlide @@ -29,17 +29,18 @@ module Patat.Presentation.Internal -------------------------------------------------------------------------------- -import Control.Monad (mplus) -import qualified Data.Aeson.Extended as A -import qualified Data.Aeson.TH.Extended as A -import qualified Data.Foldable as Foldable -import Data.List (intercalate) -import Data.Maybe (fromMaybe, listToMaybe) -import qualified Data.Text as T -import qualified Patat.Theme as Theme +import Control.Monad (mplus) +import qualified Data.Aeson.Extended as A +import qualified Data.Aeson.TH.Extended as A +import qualified Data.Foldable as Foldable +import Data.List (intercalate) +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Text as T +import qualified Patat.Presentation.Instruction as Instruction +import qualified Patat.Theme as Theme import Prelude -import qualified Text.Pandoc as Pandoc -import Text.Read (readMaybe) +import qualified Text.Pandoc as Pandoc +import Text.Read (readMaybe) -------------------------------------------------------------------------------- @@ -226,16 +227,11 @@ instance A.FromJSON ImageSettings where -------------------------------------------------------------------------------- data Slide - = ContentSlide [Fragment] + = ContentSlide (Instruction.Instructions Pandoc.Block) | TitleSlide Int [Pandoc.Inline] deriving (Show) --------------------------------------------------------------------------------- -newtype Fragment = Fragment {unFragment :: [Pandoc.Block]} - deriving (Monoid, Semigroup, Show) - - -------------------------------------------------------------------------------- -- | Active slide, active fragment. type Index = (Int, Int) @@ -248,12 +244,14 @@ getSlide sidx = listToMaybe . drop sidx . pSlides -------------------------------------------------------------------------------- numFragments :: Slide -> Int -numFragments (ContentSlide fragments) = length fragments -numFragments (TitleSlide _ _) = 1 +numFragments (ContentSlide instrs) = Instruction.numFragments instrs +numFragments (TitleSlide _ _) = 1 -------------------------------------------------------------------------------- -data ActiveFragment = ActiveContent Fragment | ActiveTitle Pandoc.Block +data ActiveFragment + = ActiveContent Instruction.Fragment + | ActiveTitle Pandoc.Block deriving (Show) @@ -262,11 +260,11 @@ getActiveFragment :: Presentation -> Maybe ActiveFragment getActiveFragment presentation = do let (sidx, fidx) = pActiveFragment presentation slide <- getSlide sidx presentation - case slide of - TitleSlide lvl is -> return . ActiveTitle $ + pure $ case slide of + TitleSlide lvl is -> ActiveTitle $ Pandoc.Header lvl Pandoc.nullAttr is - ContentSlide fragments -> - fmap ActiveContent . listToMaybe $ drop fidx fragments + ContentSlide instrs -> ActiveContent $ + Instruction.renderFragment fidx instrs -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs index 6aa49ab..283997a 100644 --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -12,25 +12,27 @@ module Patat.Presentation.Read -------------------------------------------------------------------------------- -import Control.Monad.Except (ExceptT (..), runExceptT, - throwError) -import Control.Monad.Trans (liftIO) -import qualified Data.Aeson as A -import Data.Bifunctor (first) -import qualified Data.HashMap.Strict as HMS -import Data.Maybe (fromMaybe) -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 Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.Trans (liftIO) +import qualified Data.Aeson as A +import Data.Bifunctor (first) +import qualified Data.HashMap.Strict as HMS +import Data.Maybe (fromMaybe) +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.Presentation.Fragment +import qualified Patat.Presentation.Instruction as Instruction import Patat.Presentation.Internal import Prelude -import System.Directory (doesFileExist, getHomeDirectory) -import System.FilePath (splitFileName, takeExtension, - ()) -import qualified Text.Pandoc.Error as Pandoc -import qualified Text.Pandoc.Extended as Pandoc +import System.Directory (doesFileExist, + getHomeDirectory) +import System.FilePath (splitFileName, takeExtension, + ()) +import qualified Text.Pandoc.Error as Pandoc +import qualified Text.Pandoc.Extended as Pandoc -------------------------------------------------------------------------------- @@ -151,10 +153,8 @@ pandocToSlides settings pandoc = fragmented = [ case slide of TitleSlide _ _ -> slide - ContentSlide fragments0 -> - let blocks = concatMap unFragment fragments0 - blockss = fragmentBlocks fragmentSettings blocks in - ContentSlide (map Fragment blockss) + ContentSlide instrs0 -> ContentSlide $ + fragmentInstructions fragmentSettings instrs0 | slide <- unfragmented ] in fragmented @@ -193,7 +193,8 @@ splitSlides slideLevel (Pandoc.Pandoc _meta blocks0) where mkContentSlide :: [Pandoc.Block] -> [Slide] mkContentSlide [] = [] -- Never create empty slides - mkContentSlide bs = [ContentSlide [Fragment bs]] + mkContentSlide bs = + [ContentSlide $ Instruction.fromList [Instruction.Append bs]] splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of (xs, []) -> mkContentSlide xs diff --git a/patat.cabal b/patat.cabal index 83f6a96..5e363bd 100644 --- a/patat.cabal +++ b/patat.cabal @@ -73,6 +73,7 @@ Library Patat.Presentation.Display.CodeBlock Patat.Presentation.Display.Table Patat.Presentation.Fragment + Patat.Presentation.Instruction Patat.Presentation.Interactive Patat.Presentation.Internal Patat.Presentation.Read diff --git a/tests/golden/outputs/fragments.md.dump b/tests/golden/outputs/fragments.md.dump index 2c20120..87fbc31 100644 --- a/tests/golden/outputs/fragments.md.dump +++ b/tests/golden/outputs/fragments.md.dump @@ -1,5 +1,4 @@ - ~~~frag  - This list @@ -10,8 +9,6 @@  - is displayed - - ~~~frag  - This list