--------------------------------------------------------------------------------
-- | 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.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Patat.Presentation.Instruction
    ( Instructions
    , fromList
    , toList

    , Var
    , VarGen
    , zeroVarGen
    , freshVar

    , Instruction (..)
    , beforePause
    , numFragments
    , variables

    , Fragment (..)
    , renderFragment
    ) where

import           Data.Hashable (Hashable)
import qualified Data.HashSet as HS
import           Data.List     (foldl')
import qualified Text.Pandoc   as Pandoc

newtype Instructions a = Instructions {forall a. Instructions a -> [Instruction a]
unInstructions :: [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

-- | A variable is like a placeholder in the instructions, something we don't
-- know yet, dynamic content.  Currently this is only used for code evaluation.
newtype Var = Var Int deriving (Eq Var
Eq Var => (Int -> Var -> Int) -> (Var -> Int) -> Hashable Var
Int -> Var -> Int
Var -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Var -> Int
hashWithSalt :: Int -> Var -> Int
$chash :: Var -> Int
hash :: Var -> Int
Hashable, Var -> Var -> Bool
(Var -> Var -> Bool) -> (Var -> Var -> Bool) -> Eq Var
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Var -> Var -> Bool
== :: Var -> Var -> Bool
$c/= :: Var -> Var -> Bool
/= :: Var -> Var -> Bool
Eq, Eq Var
Eq Var =>
(Var -> Var -> Ordering)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Var)
-> (Var -> Var -> Var)
-> Ord Var
Var -> Var -> Bool
Var -> Var -> Ordering
Var -> Var -> Var
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Var -> Var -> Ordering
compare :: Var -> Var -> Ordering
$c< :: Var -> Var -> Bool
< :: Var -> Var -> Bool
$c<= :: Var -> Var -> Bool
<= :: Var -> Var -> Bool
$c> :: Var -> Var -> Bool
> :: Var -> Var -> Bool
$c>= :: Var -> Var -> Bool
>= :: Var -> Var -> Bool
$cmax :: Var -> Var -> Var
max :: Var -> Var -> Var
$cmin :: Var -> Var -> Var
min :: Var -> Var -> Var
Ord, Int -> Var -> ShowS
[Var] -> ShowS
Var -> String
(Int -> Var -> ShowS)
-> (Var -> String) -> ([Var] -> ShowS) -> Show Var
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Var -> ShowS
showsPrec :: Int -> Var -> ShowS
$cshow :: Var -> String
show :: Var -> String
$cshowList :: [Var] -> ShowS
showList :: [Var] -> ShowS
Show)

-- | Used to generate fresh variables.
newtype VarGen = VarGen Int deriving (Int -> VarGen -> ShowS
[VarGen] -> ShowS
VarGen -> String
(Int -> VarGen -> ShowS)
-> (VarGen -> String) -> ([VarGen] -> ShowS) -> Show VarGen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VarGen -> ShowS
showsPrec :: Int -> VarGen -> ShowS
$cshow :: VarGen -> String
show :: VarGen -> String
$cshowList :: [VarGen] -> ShowS
showList :: [VarGen] -> ShowS
Show)

zeroVarGen :: VarGen
zeroVarGen :: VarGen
zeroVarGen = Int -> VarGen
VarGen Int
0

freshVar :: VarGen -> (Var, VarGen)
freshVar :: VarGen -> (Var, VarGen)
freshVar (VarGen Int
x) = (Int -> Var
Var Int
x, Int -> VarGen
VarGen (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

data Instruction a
    -- Pause.
    = Pause
    -- Append items.
    | Append [a]
    -- Append the content of a variable.
    | AppendVar Var
    -- 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 (AppendVar Var
_)  = 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

beforePause :: Int -> Instructions a -> Instructions a
beforePause :: forall a. Int -> Instructions a -> Instructions a
beforePause Int
n = [Instruction a] -> Instructions a
forall a. [Instruction a] -> Instructions a
Instructions ([Instruction a] -> Instructions a)
-> (Instructions a -> [Instruction a])
-> Instructions a
-> Instructions a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Instruction a] -> [Instruction a]
forall {a}. Int -> [Instruction a] -> [Instruction a]
go Int
0 ([Instruction a] -> [Instruction a])
-> (Instructions a -> [Instruction a])
-> Instructions a
-> [Instruction a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instructions a -> [Instruction a]
forall a. Instructions a -> [Instruction a]
unInstructions
  where
    go :: Int -> [Instruction a] -> [Instruction a]
go Int
_ []          = []
    go Int
i (Instruction a
Pause : [Instruction a]
t) = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n then [] else Int -> [Instruction a] -> [Instruction a]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Instruction a]
t
    go Int
i (Instruction a
h     : [Instruction a]
t) = Instruction a
h Instruction a -> [Instruction a] -> [Instruction a]
forall a. a -> [a] -> [a]
: Int -> [Instruction a] -> [Instruction a]
go Int
i [Instruction a]
t

variables :: Instructions a -> HS.HashSet Var
variables :: forall a. Instructions a -> HashSet Var
variables (Instructions []               )  = HashSet Var
forall a. Monoid a => a
mempty
variables (Instructions (AppendVar Var
v : [Instruction a]
t))  = Var -> HashSet Var -> HashSet Var
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert Var
v (Instructions a -> HashSet Var
forall a. Instructions a -> HashSet Var
variables ([Instruction a] -> Instructions a
forall a. [Instruction a] -> Instructions a
Instructions [Instruction a]
t))
variables (Instructions (ModifyLast Instruction a
i : [Instruction a]
t)) = Instructions a -> HashSet Var
forall a. Instructions a -> HashSet Var
variables ([Instruction a] -> Instructions a
forall a. [Instruction a] -> Instructions a
Instructions [Instruction a]
t) HashSet Var -> HashSet Var -> HashSet Var
forall a. Semigroup a => a -> a -> a
<> Instructions a -> HashSet Var
forall a. Instructions a -> HashSet Var
variables ([Instruction a] -> Instructions a
forall a. [Instruction a] -> Instructions a
Instructions [Instruction a
i])
variables (Instructions (Instruction a
_           : [Instruction a]
t))  = Instructions a -> HashSet Var
forall a. Instructions a -> HashSet Var
variables ([Instruction a] -> Instructions a
forall a. [Instruction a] -> Instructions a
Instructions [Instruction a]
t)

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
    :: (Var -> [Pandoc.Block]) -> Instructions Pandoc.Block -> Fragment
renderFragment :: (Var -> [Block]) -> Instructions Block -> Fragment
renderFragment Var -> [Block]
resolve = \Instructions Block
instrs -> [Block] -> Fragment
Fragment ([Block] -> Fragment) -> [Block] -> Fragment
forall a b. (a -> b) -> a -> b
$ ([Block] -> Instruction Block -> [Block])
-> [Block] -> [Instruction Block] -> [Block]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    (\[Block]
acc Instruction Block
instr -> (Var -> [Block]) -> Instruction Block -> [Block] -> [Block]
goBlocks Var -> [Block]
resolve Instruction Block
instr [Block]
acc) [] (Instructions Block -> [Instruction Block]
forall a. Instructions a -> [Instruction a]
unInstructions Instructions Block
instrs)

goBlocks
    :: (Var -> [Pandoc.Block]) -> Instruction Pandoc.Block -> [Pandoc.Block]
    -> [Pandoc.Block]
goBlocks :: (Var -> [Block]) -> Instruction Block -> [Block] -> [Block]
goBlocks Var -> [Block]
_ Instruction Block
Pause [Block]
xs = [Block]
xs
goBlocks Var -> [Block]
_ (Append [Block]
ys) [Block]
xs = [Block]
xs [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ [Block]
ys
goBlocks Var -> [Block]
resolve (AppendVar Var
v) [Block]
xs = [Block]
xs [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ Var -> [Block]
resolve Var
v
goBlocks Var -> [Block]
_ Instruction Block
Delete [Block]
xs = [Block] -> [Block]
forall a. [a] -> [a]
sinit [Block]
xs
goBlocks Var -> [Block]
resolve (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 ((Var -> [Block]) -> Instruction Block -> Block -> Block
goBlock Var -> [Block]
resolve Instruction Block
f) [Block]
xs

goBlock
    :: (Var -> [Pandoc.Block]) -> Instruction Pandoc.Block -> Pandoc.Block
    -> Pandoc.Block
goBlock :: (Var -> [Block]) -> Instruction Block -> Block -> Block
goBlock Var -> [Block]
_ Instruction Block
Pause Block
x = Block
x
goBlock Var -> [Block]
_ (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 Var -> [Block]
resolve (AppendVar Var
v) 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]
++ [Var -> [Block]
resolve Var
v]
    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]
++ [Var -> [Block]
resolve Var
v]
    Block
_                          -> Block
block
goBlock Var -> [Block]
_ Instruction Block
Delete Block
block = case Block
block of
    -- We can only delete from 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 Var -> [Block]
resolve (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 ((Var -> [Block]) -> Instruction Block -> [Block] -> [Block]
goBlocks Var -> [Block]
resolve 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 ((Var -> [Block]) -> Instruction Block -> [Block] -> [Block]
goBlocks Var -> [Block]
resolve 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