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

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

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

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

renderFragment :: Int -> Instructions Pandoc.Block -> Fragment
renderFragment :: Int -> Instructions Block -> Fragment
renderFragment = \Int
n (Instructions [Instruction Block]
instrs) -> [Block] -> Fragment
Fragment ([Block] -> Fragment) -> [Block] -> Fragment
forall a b. (a -> b) -> a -> b
$ [Block] -> Int -> [Instruction Block] -> [Block]
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 t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 then [Block]
acc else [Block] -> t -> [Instruction Block] -> [Block]
go [Block]
acc (t
n t -> t -> t
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 [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ [Block]
ys
goBlocks Instruction Block
Delete [Block]
xs = [Block] -> [Block]
forall a. [a] -> [a]
sinit [Block]
xs
goBlocks (ModifyLast Instruction Block
f) [Block]
xs
    | [Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
xs   = [Block]
xs  -- Shouldn't happen unless instructions are malformed.
    | Bool
otherwise = (Block -> Block) -> [Block] -> [Block]
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 ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$ [[Block]]
xs [[Block]] -> [[Block]] -> [[Block]]
forall a. [a] -> [a] -> [a]
++ [[Block]
ys]
    Pandoc.OrderedList ListAttributes
attr [[Block]]
xs -> ListAttributes -> [[Block]] -> Block
Pandoc.OrderedList ListAttributes
attr ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$ [[Block]]
xs [[Block]] -> [[Block]] -> [[Block]]
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 ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$ [[Block]] -> [[Block]]
forall a. [a] -> [a]
sinit [[Block]]
xs
    Pandoc.OrderedList ListAttributes
attr [[Block]]
xs -> ListAttributes -> [[Block]] -> Block
Pandoc.OrderedList ListAttributes
attr ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$ [[Block]] -> [[Block]]
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 ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$ ([Block] -> [Block]) -> [[Block]] -> [[Block]]
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 ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$ ([Block] -> [Block]) -> [[Block]] -> [[Block]]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> [a] -> [a]
forall a. (a -> a) -> [a] -> [a]
modifyLast a -> a
f (a
y a -> [a] -> [a]
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 [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs then [] else [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
xs