summaryrefslogtreecommitdiff
path: root/lib/Patat/Presentation/Fragment.hs
blob: 090838198145eb31c554a38e07bd9fe896c9273f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
-- | For background info on the spec, see the "Incremental lists" section of the
-- the pandoc manual.
{-# LANGUAGE CPP               #-}
{-# 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           Prelude
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]

-- | 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

#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])

    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