Merge pull request #24 from jaspervdj/feature/fragments

Support for fragmented slides

README.md

@@ -35,6 +35,7 @@ Table of Contents
 -   [Running](#running)
 -   [Input format](#input-format)
 -   [Configuration](#configuration)
+    -   [Fragmented slides](#fragmented-slides)
     -   [Theming](#theming)
     -   [Syntax Highlighting](#syntax-highlighting)
 -   [Trivia](#trivia)
@@ -171,6 +172,65 @@ Or we can use a normal presentation and have the following `$HOME/.patat.yaml`:
 
     wrap: true
 
+### Fragmented slides
+
+By default, slides are always displayed "all at once".  If you want to display
+them fragment by fragment, there are two ways to do that.  The most common
+case is that lists should be displayed incrementally.
+
+This can be configured by settings `incrementalLists` to `true` in the metadata
+block:
+
+    ---
+    title: Presentation with incremental lists
+    author: John Doe
+    patat:
+        incrementalLists: true
+    ...
+
+    - This list
+    - is displayed
+    - item by item
+
+Setting `incrementalLists` works on _all_ lists in the presentation.  To flip
+the setting for a specific list, wrap it in a block quote.  This will make the
+list incremental if `incrementalLists` is not set, and it will display the list
+all at once if `incrementalLists` is set to `true`.
+
+This example contains a sublist which is also displayed incrementally, and then
+a sublist which is displayed all at once (by merit of the block quote).
+
+    ---
+    title: Presentation with incremental lists
+    author: John Doe
+    patat:
+        incrementalLists: true
+    ...
+
+    - This list
+    - is displayed
+
+        * item
+        * by item
+
+    - Or sometimes
+
+        > * all at
+        > * once
+
+Another way to break up slides is to use a pagraph only containing three dots
+separated by spaces.  For example, this slide has two pauses:
+
+    Legen
+
+    . . .
+
+    wait for it
+
+    . . .
+
+    Dary!
+
 ### Theming
 
 Colors and other properties can also be changed using this configuration.  For

patat.cabal

@@ -49,6 +49,7 @@ Executable patat
     Patat.Presentation.Display
     Patat.Presentation.Display.CodeBlock
     Patat.Presentation.Display.Table
+    Patat.Presentation.Fragment
     Patat.Presentation.Interactive
     Patat.Presentation.Internal
     Patat.Presentation.Read

src/Patat/Presentation.hs

@@ -15,6 +15,7 @@ module Patat.Presentation
     ) where
 
 import           Patat.Presentation.Display
+import           Patat.Presentation.Fragment
 import           Patat.Presentation.Interactive
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Read

src/Patat/Presentation/Display.hs

@@ -65,7 +65,8 @@ displayWithBorders Presentation {..} f = do
     PP.putDoc $ withWrapSettings settings $ f theme
     putStrLn ""
 
-    let active      = show (pActiveSlide + 1) ++ " / " ++ show (length pSlides)
+    let (sidx, _)   = pActiveFragment
+        active      = show (sidx + 1) ++ " / " ++ show (length pSlides)
         activeWidth = length active
 
     Ansi.setCursorPosition (rows - 2) 0
@@ -78,11 +79,8 @@ displayWithBorders Presentation {..} f = do
 --------------------------------------------------------------------------------
 displayPresentation :: Presentation -> IO ()
 displayPresentation pres@Presentation {..} = displayWithBorders pres $ \theme ->
-    let slide = case drop pActiveSlide pSlides of
-            []      -> mempty
-            (s : _) -> s in
-
-    prettySlide theme slide
+    let fragment = fromMaybe mempty (getActiveFragment pres) in
+    prettyFragment theme fragment
 
 
 --------------------------------------------------------------------------------
@@ -100,8 +98,11 @@ dumpPresentation :: Presentation -> IO ()
 dumpPresentation pres =
     let theme = fromMaybe Theme.defaultTheme (psTheme $ pSettings pres) in
     PP.putDoc $ withWrapSettings (pSettings pres) $
-        PP.vcat $ intersperse "----------" $
-        map (prettySlide theme) $ pSlides pres
+        PP.vcat $ intersperse "----------" $ do
+            Slide fragments <- pSlides pres
+            return $ PP.vcat $ intersperse "~~~~~~~~~~" $ do
+                fragment <- fragments
+                return $ prettyFragment theme fragment
 
 
 --------------------------------------------------------------------------------
@@ -112,10 +113,10 @@ withWrapSettings ps = case (psWrap ps, psColumns ps) of
 
 
 --------------------------------------------------------------------------------
-prettySlide :: Theme -> Slide -> PP.Doc
-prettySlide theme slide@(Slide blocks) =
+prettyFragment :: Theme -> Fragment -> PP.Doc
+prettyFragment theme fragment@(Fragment blocks) =
     prettyBlocks theme blocks <>
-    case prettyReferences theme slide of
+    case prettyReferences theme fragment of
         []   -> mempty
         refs -> PP.hardline <> PP.vcat refs
 
@@ -284,9 +285,9 @@ prettyInlines theme = mconcat . map (prettyInline theme)
 
 
 --------------------------------------------------------------------------------
-prettyReferences :: Theme -> Slide -> [PP.Doc]
+prettyReferences :: Theme -> Fragment -> [PP.Doc]
 prettyReferences theme@Theme {..} =
-    map prettyReference . getReferences . unSlide
+    map prettyReference . getReferences . unFragment
   where
     getReferences :: [Pandoc.Block] -> [Pandoc.Inline]
     getReferences = filter isReferenceLink . grecQ

src/Patat/Presentation/Fragment.hs

@@ -0,0 +1,129 @@
+-- | For background info on the spec, see the "Incremental lists" section of the
+-- the pandoc manual.
+{-# LANGUAGE DeriveFoldable    #-}
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE DeriveTraversable #-}
+module Patat.Presentation.Fragment
+    ( FragmentSettings (..)
+    , fragmentBlocks
+    , fragmentBlock
+    ) where
+
+import           Data.Foldable    (Foldable)
+import           Data.List        (foldl', intersperse)
+import           Data.Maybe       (fromMaybe)
+import           Data.Traversable (Traversable)
+import qualified Text.Pandoc      as Pandoc
+import           Prelude
+
+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]
+
+-- | 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)
+
+fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block
+fragmentBlock _fs block@(Pandoc.Para inlines)
+    | inlines == threeDots = Fragmented [Nothing] Nothing
+    | otherwise            = Unfragmented block
+  where
+    threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".")
+
+fragmentBlock fs (Pandoc.BulletList bs0) =
+    fragmentList fs (fsIncrementalLists fs) Pandoc.BulletList bs0
+
+fragmentBlock fs (Pandoc.OrderedList attr bs0) =
+    fragmentList fs (fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0
+
+fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) =
+    fragmentList fs (not $ fsIncrementalLists fs) 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
+
+joinFragmentedBlocks :: [Fragmented block] -> Fragmented [block]
+joinFragmentedBlocks =
+    foldl' append (Unfragmented [])
+  where
+    append (Unfragmented xs) (Unfragmented y) =
+        Unfragmented (xs ++ [y])
+
+    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])
+
+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
+  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

src/Patat/Presentation/Interactive.hs

@@ -78,23 +78,43 @@ updatePresentation
 
 updatePresentation cmd presentation = case cmd of
     Exit         -> return ExitedPresentation
-    Forward      -> return $ goToSlide (\x -> x + 1)
-    Backward     -> return $ goToSlide (\x -> x - 1)
-    SkipForward  -> return $ goToSlide (\x -> x + 10)
-    SkipBackward -> return $ goToSlide (\x -> x - 10)
-    First        -> return $ goToSlide (\_ -> 0)
-    Last         -> return $ goToSlide (\_ -> numSlides presentation - 1)
+    Forward      -> return $ goToSlide $ \(s, f) -> (s, f + 1)
+    Backward     -> return $ goToSlide $ \(s, f) -> (s, f - 1)
+    SkipForward  -> return $ goToSlide $ \(s, _) -> (s + 10, 0)
+    SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0)
+    First        -> return $ goToSlide $ \_ -> (0, 0)
+    Last         -> return $ goToSlide $ \_ -> (numSlides presentation, 0)
     Reload       -> reloadPresentation
   where
+    numSlides :: Presentation -> Int
     numSlides pres = length (pSlides pres)
-    clip idx  pres = min (max 0 idx) (numSlides pres - 1)
 
-    goToSlide f = UpdatedPresentation $
-        presentation {pActiveSlide = clip (f $ pActiveSlide presentation) presentation}
+    clip :: Index -> Presentation -> Index
+    clip (slide, fragment) pres
+        | slide    >= numSlides pres = (numSlides pres - 1, lastFragments - 1)
+        | slide    <  0              = (0, 0)
+        | fragment >= numFragments slide =
+            if slide + 1 >= numSlides pres
+                then (slide, lastFragments - 1)
+                else (slide + 1, 0)
+        | fragment < 0 =
+            if slide - 1 >= 0
+                then (slide - 1, numFragments (slide - 1) - 1)
+                else (slide, 0)
+        | otherwise                  = (slide, fragment)
+      where
+        numFragments s = maybe 1 (length . unSlide) (getSlide s pres)
+        lastFragments  = numFragments (numSlides pres - 1)
+
+    goToSlide :: (Index -> Index) -> UpdatedPresentation
+    goToSlide f = UpdatedPresentation $ presentation
+        { pActiveFragment = clip (f $ pActiveFragment presentation) presentation
+        }
 
     reloadPresentation = do
         errOrPres <- readPresentation (pFilePath presentation)
         return $ case errOrPres of
             Left  err  -> ErroredPresentation err
-            Right pres -> UpdatedPresentation $
-                pres {pActiveSlide = clip (pActiveSlide presentation) pres}
+            Right pres -> UpdatedPresentation $ pres
+                { pActiveFragment = clip (pActiveFragment presentation) pres
+                }

src/Patat/Presentation/Internal.hs

@@ -6,6 +6,11 @@ module Patat.Presentation.Internal
     , PresentationSettings (..)
     , defaultPresentationSettings
     , Slide (..)
+    , Fragment (..)
+    , Index
+
+    , getSlide
+    , getActiveFragment
     ) where
 
 
@@ -13,7 +18,8 @@ module Patat.Presentation.Internal
 import           Control.Monad          (mplus)
 import qualified Data.Aeson.Extended    as A
 import qualified Data.Aeson.TH.Extended as A
-import           Data.Monoid            (Monoid (..))
+import           Data.Maybe             (listToMaybe)
+import           Data.Monoid            (Monoid (..), (<>))
 import qualified Patat.Theme            as Theme
 import qualified Text.Pandoc            as Pandoc
 import           Prelude
@@ -21,12 +27,12 @@ import           Prelude
 
 --------------------------------------------------------------------------------
 data Presentation = Presentation
-    { pFilePath    :: !FilePath
-    , pTitle       :: ![Pandoc.Inline]
-    , pAuthor      :: ![Pandoc.Inline]
-    , pSettings    :: !PresentationSettings
-    , pSlides      :: [Slide]
-    , pActiveSlide :: !Int
+    { pFilePath       :: !FilePath
+    , pTitle          :: ![Pandoc.Inline]
+    , pAuthor         :: ![Pandoc.Inline]
+    , pSettings       :: !PresentationSettings
+    , pSlides         :: [Slide]
+    , pActiveFragment :: !Index
     } deriving (Show)
 
 
@@ -34,38 +40,64 @@ data Presentation = Presentation
 -- | These are patat-specific settings.  That is where they differ from more
 -- general metadata (author, title...)
 data PresentationSettings = PresentationSettings
-    { psRows    :: !(Maybe (A.FlexibleNum Int))
-    , psColumns :: !(Maybe (A.FlexibleNum Int))
-    , psWrap    :: !(Maybe Bool)
-    , psTheme   :: !(Maybe Theme.Theme)
+    { psRows             :: !(Maybe (A.FlexibleNum Int))
+    , psColumns          :: !(Maybe (A.FlexibleNum Int))
+    , psWrap             :: !(Maybe Bool)
+    , psTheme            :: !(Maybe Theme.Theme)
+    , psIncrementalLists :: !(Maybe Bool)
     } deriving (Show)
 
 
 --------------------------------------------------------------------------------
 instance Monoid PresentationSettings where
-    mempty      = PresentationSettings Nothing Nothing Nothing Nothing
+    mempty      = PresentationSettings Nothing Nothing Nothing Nothing Nothing
     mappend l r = PresentationSettings
-        { psRows    = psRows    l `mplus`   psRows    r
-        , psColumns = psColumns l `mplus`   psColumns r
-        , psWrap    = psWrap    l `mplus`   psWrap    r
-        , psTheme   = psTheme   l `mappend` psTheme   r
+        { psRows             = psRows             l `mplus` psRows    r
+        , psColumns          = psColumns          l `mplus` psColumns r
+        , psWrap             = psWrap             l `mplus` psWrap    r
+        , psTheme            = psTheme            l <>      psTheme   r
+        , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r
         }
 
 
 --------------------------------------------------------------------------------
 defaultPresentationSettings :: PresentationSettings
 defaultPresentationSettings = PresentationSettings
-    { psRows    = Nothing
-    , psColumns = Nothing
-    , psWrap    = Nothing
-    , psTheme   = Just Theme.defaultTheme
+    { psRows             = Nothing
+    , psColumns          = Nothing
+    , psWrap             = Nothing
+    , psTheme            = Just Theme.defaultTheme
+    , psIncrementalLists = Nothing
     }
 
 
 --------------------------------------------------------------------------------
-newtype Slide = Slide {unSlide :: [Pandoc.Block]}
+newtype Slide = Slide {unSlide :: [Fragment]}
     deriving (Monoid, Show)
 
 
+--------------------------------------------------------------------------------
+newtype Fragment = Fragment {unFragment :: [Pandoc.Block]}
+    deriving (Monoid, Show)
+
+
+--------------------------------------------------------------------------------
+-- | Active slide, active fragment.
+type Index = (Int, Int)
+
+
+--------------------------------------------------------------------------------
+getSlide :: Int -> Presentation -> Maybe Slide
+getSlide sidx = listToMaybe . drop sidx . pSlides
+
+
+--------------------------------------------------------------------------------
+getActiveFragment :: Presentation -> Maybe Fragment
+getActiveFragment presentation = do
+    let (sidx, fidx) = pActiveFragment presentation
+    Slide fragments <- getSlide sidx presentation
+    listToMaybe $ drop fidx fragments
+
+
 --------------------------------------------------------------------------------
 $(A.deriveJSON A.dropPrefixOptions ''PresentationSettings)

src/Patat/Presentation/Read.hs

@@ -12,9 +12,11 @@ import           Control.Monad.Except        (ExceptT (..), runExceptT,
 import           Control.Monad.Trans         (liftIO)
 import qualified Data.Aeson                  as A
 import qualified Data.ByteString             as B
+import           Data.Maybe                  (fromMaybe)
 import           Data.Monoid                 (mempty, (<>))
 import qualified Data.Set                    as Set
 import qualified Data.Yaml                   as Yaml
+import           Patat.Presentation.Fragment
 import           Patat.Presentation.Internal
 import           System.Directory            (doesFileExist, getHomeDirectory)
 import           System.FilePath             (takeExtension, (</>))
@@ -65,10 +67,10 @@ pandocToPresentation
     :: FilePath -> PresentationSettings -> Pandoc.Pandoc
     -> Either String Presentation
 pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
-    let !pTitle       = Pandoc.docTitle meta
-        !pSlides      = pandocToSlides pandoc
-        !pActiveSlide = 0
-        !pAuthor      = concat (Pandoc.docAuthors meta)
+    let !pTitle          = Pandoc.docTitle meta
+        !pSlides         = pandocToSlides pSettings pandoc
+        !pActiveFragment = (0, 0)
+        !pAuthor         = concat (Pandoc.docAuthors meta)
     return Presentation {..}
 
 
@@ -99,23 +101,34 @@ readHomeSettings = do
             return $! Yaml.decodeEither contents
 
 
+--------------------------------------------------------------------------------
+pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> [Slide]
+pandocToSlides settings pandoc =
+    let blockss = splitSlides pandoc in
+    map (Slide . map Fragment . (fragmentBlocks fragmentSettings)) blockss
+  where
+    fragmentSettings = FragmentSettings
+        { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
+        }
+
+
 --------------------------------------------------------------------------------
 -- | Split a pandoc document into slides.  If the document contains horizonal
 -- rules, we use those as slide delimiters.  If there are no horizontal rules,
 -- we split using h1 headers.
-pandocToSlides :: Pandoc.Pandoc -> [Slide]
-pandocToSlides (Pandoc.Pandoc _meta blocks0)
+splitSlides :: Pandoc.Pandoc -> [[Pandoc.Block]]
+splitSlides (Pandoc.Pandoc _meta blocks0)
     | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0
     | otherwise                              = splitAtH1s   blocks0
   where
     splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of
-        (xs, [])           -> [Slide xs]
-        (xs, (_rule : ys)) -> Slide xs : splitAtRules ys
+        (xs, [])           -> [xs]
+        (xs, (_rule : ys)) -> xs : splitAtRules ys
 
     splitAtH1s []       = []
     splitAtH1s (b : bs) = case break isH1 bs of
-        (xs, [])       -> [Slide (b : xs)]
-        (xs, (y : ys)) -> Slide (b : xs) : splitAtH1s (y : ys)
+        (xs, [])       -> [(b : xs)]
+        (xs, (y : ys)) -> (b : xs) : splitAtH1s (y : ys)
 
     isH1 (Pandoc.Header i _ _) = i == 1
     isH1 _                     = False

tests/fragments.md

@@ -0,0 +1,27 @@
+---
+patat:
+  incrementalLists: true
+...
+
+- This list
+- is displayed
+
+    * item
+    * by item
+
+- Or sometimes
+
+    > * all at
+    > * once
+
+---
+
+Legen
+
+. . .
+
+wait for it
+
+. . .
+
+Dary!

tests/fragments.md.dump

@@ -0,0 +1,54 @@
+
+
+~~~~~~~~~~
+  - This list
+
+~~~~~~~~~~
+  - This list
+  - is displayed
+
+
+
+
+~~~~~~~~~~
+  - This list
+  - is displayed
+
+      * item
+
+
+~~~~~~~~~~
+  - This list
+  - is displayed
+
+      * item
+      * by item
+
+
+~~~~~~~~~~
+  - This list
+  - is displayed
+
+      * item
+      * by item
+
+  - Or sometimes
+
+      * all at
+      * once
+
+
+----------
+Legen
+
+~~~~~~~~~~
+Legen
+
+wait for it
+
+~~~~~~~~~~
+Legen
+
+wait for it
+
+Dary!