Skip to content

Commit

Permalink
Refactor implementation of fragments.
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
jaspervdj committed Sep 10, 2020
1 parent 6dd81b4 commit 2567bc6
Show file tree
Hide file tree
Showing 7 changed files with 193 additions and 142 deletions.
17 changes: 10 additions & 7 deletions lib/Patat/Presentation/Display.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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


--------------------------------------------------------------------------------
Expand All @@ -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

Expand Down Expand Up @@ -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
Expand Down
132 changes: 45 additions & 87 deletions lib/Patat/Presentation/Fragment.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ".")

Expand All @@ -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)
93 changes: 93 additions & 0 deletions lib/Patat/Presentation/Instruction.hs
Original file line number Diff line number Diff line change
@@ -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 _ [] = []
46 changes: 22 additions & 24 deletions lib/Patat/Presentation/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ module Patat.Presentation.Internal
, ImageSettings (..)

, Slide (..)
, Fragment (..)
, Instruction.Fragment (..)
, Index

, getSlide
Expand All @@ -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)


--------------------------------------------------------------------------------
Expand Down Expand Up @@ -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)
Expand All @@ -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)


Expand All @@ -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


--------------------------------------------------------------------------------
Expand Down
Loading

0 comments on commit 2567bc6

Please sign in to comment.