--------------------------------------------------------------------------------
-- | 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 (Int -> Instructions a -> ShowS
forall a. Show a => Int -> Instructions a -> ShowS
forall a. Show a => [Instructions a] -> ShowS
forall a. Show a => Instructions a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instructions a] -> ShowS
$cshowList :: forall a. Show a => [Instructions a] -> ShowS
show :: Instructions a -> String
$cshow :: forall a. Show a => Instructions a -> String
showsPrec :: Int -> Instructions a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Instructions a -> ShowS
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 :: forall a. [Instruction a] -> Instructions a
fromList = forall a. [Instruction a] -> Instructions a
Instructions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [Instruction a] -> [Instruction a]
go
  where
    go :: [Instruction a] -> [Instruction a]
go [Instruction a]
instrs = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Instruction a -> Bool
isPause) [Instruction a]
instrs of
        ([Instruction a]
_, [])             -> []
        (Instruction a
_ : [Instruction a]
_, [Instruction a]
remainder)  -> forall a. Instruction a
Pause forall a. a -> [a] -> [a]
: [Instruction a] -> [Instruction a]
go [Instruction a]
remainder
        ([], Instruction a
x : [Instruction a]
remainder) -> Instruction a
x forall a. a -> [a] -> [a]
: [Instruction a] -> [Instruction a]
go [Instruction a]
remainder

toList :: Instructions a -> [Instruction a]
toList :: forall a. Instructions a -> [Instruction a]
toList (Instructions [Instruction a]
xs) = [Instruction a]
xs

data Instruction a
    -- Pause.
    = Pause
    -- Append items.
    | Append [a]
    -- Remove the last item.
    | Delete
    -- Modify the last block with the provided instruction.
    | ModifyLast (Instruction a)
    deriving (Int -> Instruction a -> ShowS
forall a. Show a => Int -> Instruction a -> ShowS
forall a. Show a => [Instruction a] -> ShowS
forall a. Show a => Instruction a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instruction a] -> ShowS
$cshowList :: forall a. Show a => [Instruction a] -> ShowS
show :: Instruction a -> String
$cshow :: forall a. Show a => Instruction a -> String
showsPrec :: Int -> Instruction a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Instruction a -> ShowS
Show)

isPause :: Instruction a -> Bool
isPause :: forall a. Instruction a -> Bool
isPause Instruction a
Pause = Bool
True
isPause (Append [a]
_) = Bool
False
isPause Instruction a
Delete = Bool
False
isPause (ModifyLast Instruction a
i) = forall a. Instruction a -> Bool
isPause Instruction a
i

numPauses :: Instructions a -> Int
numPauses :: forall a. Instructions a -> Int
numPauses (Instructions [Instruction a]
xs) = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Instruction a -> Bool
isPause [Instruction a]
xs

numFragments :: Instructions a -> Int
numFragments :: forall a. Instructions a -> Int
numFragments = forall a. Enum a => a -> a
succ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Instructions a -> Int
numPauses

newtype Fragment = Fragment [Pandoc.Block] deriving (Int -> Fragment -> ShowS
[Fragment] -> ShowS
Fragment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fragment] -> ShowS
$cshowList :: [Fragment] -> ShowS
show :: Fragment -> String
$cshow :: Fragment -> String
showsPrec :: Int -> Fragment -> ShowS
$cshowsPrec :: Int -> Fragment -> ShowS
Show)

renderFragment :: Int -> Instructions Pandoc.Block -> Fragment
renderFragment :: Int -> Instructions Block -> Fragment
renderFragment = \Int
n (Instructions [Instruction Block]
instrs) -> [Block] -> Fragment
Fragment forall a b. (a -> b) -> a -> b
$ forall {t}.
(Ord t, Num t) =>
[Block] -> t -> [Instruction Block] -> [Block]
go [] Int
n [Instruction Block]
instrs
  where
    go :: [Block] -> t -> [Instruction Block] -> [Block]
go [Block]
acc t
_ []         = [Block]
acc
    go [Block]
acc t
n (Instruction Block
Pause : [Instruction Block]
instrs) = if t
n forall a. Ord a => a -> a -> Bool
<= t
0 then [Block]
acc else [Block] -> t -> [Instruction Block] -> [Block]
go [Block]
acc (t
n forall a. Num a => a -> a -> a
- t
1) [Instruction Block]
instrs
    go [Block]
acc t
n (Instruction Block
instr : [Instruction Block]
instrs) = [Block] -> t -> [Instruction Block] -> [Block]
go (Instruction Block -> [Block] -> [Block]
goBlocks Instruction Block
instr [Block]
acc) t
n [Instruction Block]
instrs

goBlocks :: Instruction Pandoc.Block -> [Pandoc.Block] -> [Pandoc.Block]
goBlocks :: Instruction Block -> [Block] -> [Block]
goBlocks Instruction Block
Pause [Block]
xs = [Block]
xs
goBlocks (Append [Block]
ys) [Block]
xs = [Block]
xs forall a. [a] -> [a] -> [a]
++ [Block]
ys
goBlocks Instruction Block
Delete [Block]
xs = forall a. [a] -> [a]
sinit [Block]
xs
goBlocks (ModifyLast Instruction Block
f) [Block]
xs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
xs   = [Block]
xs  -- Shouldn't happen unless instructions are malformed.
    | Bool
otherwise = forall a. (a -> a) -> [a] -> [a]
modifyLast (Instruction Block -> Block -> Block
goBlock Instruction Block
f) [Block]
xs

goBlock :: Instruction Pandoc.Block -> Pandoc.Block -> Pandoc.Block
goBlock :: Instruction Block -> Block -> Block
goBlock Instruction Block
Pause Block
x = Block
x
goBlock (Append [Block]
ys) Block
block = case Block
block of
    -- We can only append to a few specific block types for now.
    Pandoc.BulletList [[Block]]
xs -> [[Block]] -> Block
Pandoc.BulletList forall a b. (a -> b) -> a -> b
$ [[Block]]
xs forall a. [a] -> [a] -> [a]
++ [[Block]
ys]
    Pandoc.OrderedList ListAttributes
attr [[Block]]
xs -> ListAttributes -> [[Block]] -> Block
Pandoc.OrderedList ListAttributes
attr forall a b. (a -> b) -> a -> b
$ [[Block]]
xs forall a. [a] -> [a] -> [a]
++ [[Block]
ys]
    Block
_ -> Block
block
goBlock Instruction Block
Delete Block
block = case Block
block of
    -- We can only append to a few specific block types for now.
    Pandoc.BulletList [[Block]]
xs -> [[Block]] -> Block
Pandoc.BulletList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
sinit [[Block]]
xs
    Pandoc.OrderedList ListAttributes
attr [[Block]]
xs -> ListAttributes -> [[Block]] -> Block
Pandoc.OrderedList ListAttributes
attr forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
sinit [[Block]]
xs
    Block
_ -> Block
block
goBlock (ModifyLast Instruction Block
f) Block
block = case Block
block of
    -- We can only modify the last content of a few specific block types for
    -- now.
    Pandoc.BulletList [[Block]]
xs -> [[Block]] -> Block
Pandoc.BulletList forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> [a] -> [a]
modifyLast (Instruction Block -> [Block] -> [Block]
goBlocks Instruction Block
f) [[Block]]
xs
    Pandoc.OrderedList ListAttributes
attr [[Block]]
xs ->
        ListAttributes -> [[Block]] -> Block
Pandoc.OrderedList ListAttributes
attr forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> [a] -> [a]
modifyLast (Instruction Block -> [Block] -> [Block]
goBlocks Instruction Block
f) [[Block]]
xs
    Block
_ -> Block
block

modifyLast :: (a -> a) -> [a] -> [a]
modifyLast :: forall a. (a -> a) -> [a] -> [a]
modifyLast a -> a
f (a
x : a
y : [a]
zs) = a
x forall a. a -> [a] -> [a]
: forall a. (a -> a) -> [a] -> [a]
modifyLast a -> a
f (a
y forall a. a -> [a] -> [a]
: [a]
zs)
modifyLast a -> a
f (a
x : [])     = [a -> a
f a
x]
modifyLast a -> a
_ []           = []

sinit :: [a] -> [a]
sinit :: forall a. [a] -> [a]
sinit [a]
xs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs then [] else forall a. [a] -> [a]
init [a]
xs