content: -- | For background info on the spec, see the "Incremental lists" section of the
  -- the pandoc manual.
  {-# LANGUAGE CPP               #-}
  {-# LANGUAGE DeriveFoldable    #-}
  {-# LANGUAGE DeriveFunctor     #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE OverloadedStrings #-}
  module Patat.Presentation.Fragment
      ( FragmentSettings (..)
  
      , fragmentPresentation
      , fragmentBlocks
      , fragmentBlock
      ) where
  
  import           Control.Monad.State         (State, runState, state)
  import           Data.List                   (intersperse)
  import           Data.Maybe                  (fromMaybe)
  import qualified Data.Set                    as S
  import           Patat.Presentation.Internal
  import           Patat.Presentation.Syntax
  import           Patat.Unique
  import           Prelude
  
  fragmentPresentation :: Presentation -> Presentation
  fragmentPresentation presentation =
      let (pres, uniqueGen) = runState work (pUniqueGen presentation) in
      pres {pUniqueGen = uniqueGen}
    where
      work = do
          slides <- traverse fragmentSlide (pSlides presentation)
          pure presentation {pSlides = slides}
  
      fragmentSlide slide = case slideContent slide of
          TitleSlide   _ _     -> pure slide
          ContentSlide blocks0 -> do
              blocks1 <- fragmentBlocks fragmentSettings blocks0
              pure slide {slideContent = ContentSlide blocks1}
  
      settings = pSettings presentation
      fragmentSettings = FragmentSettings
          { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
          }
  
  data FragmentSettings = FragmentSettings
      { fsIncrementalLists :: !Bool
      } deriving (Show)
  
  type FragmentM = State UniqueGen
  
  splitOnThreeDots :: [Block] -> [[Block]]
  splitOnThreeDots blocks = case break (== threeDots) blocks of
      (pre, _ : post) -> [pre] ++ splitOnThreeDots post
      (pre, [])       -> [pre]
    where
      threeDots = Para $ intersperse Space $ replicate 3 (Str ".")
  
  fragmentBlocks
      :: FragmentSettings -> [Block] -> FragmentM [Block]
  fragmentBlocks fs blocks = (>>= fragmentAgainAfterLists) $
      case splitOnThreeDots blocks of
          [] -> pure []
          [_] -> concat <$> traverse (fragmentBlock fs) blocks
          sections0@(_ : _) -> do
              revealID <- RevealID <$> state freshUnique
              sections1 <- traverse (fragmentBlocks fs) sections0
              let pauses = length sections1 - 1
                  triggers = case sections1 of
                      [] -> replicate pauses revealID
                      (sh : st) -> blocksRevealOrder sh ++
                          [c | s <- st, c <- revealID : blocksRevealOrder s]
              pure $ pure $ Reveal ConcatWrapper $ RevealSequence
                  revealID
                  triggers
                  [(S.fromList [i .. pauses], s) | (i, s) <- zip [0 ..] sections1]
  
  fragmentBlock :: FragmentSettings -> Block -> FragmentM [Block]
  fragmentBlock _fs (Para inlines) = pure [Para inlines]
  
  fragmentBlock fs (BulletList bs0) =
      fragmentList fs (fsIncrementalLists fs) BulletListWrapper bs0
  
  fragmentBlock fs (OrderedList attr bs0) =
      fragmentList fs (fsIncrementalLists fs) (OrderedListWrapper attr) bs0
  
  fragmentBlock fs (BlockQuote [BulletList bs0]) =
      fragmentList fs (not $ fsIncrementalLists fs) BulletListWrapper bs0
  
  fragmentBlock fs (BlockQuote [OrderedList attr bs0]) =
      fragmentList fs (not $ fsIncrementalLists fs) (OrderedListWrapper attr) bs0
  
  fragmentBlock _ block@(BlockQuote {})     = pure [block]
  
  fragmentBlock _ block@(Header {})         = pure [block]
  fragmentBlock _ block@(Plain {})          = pure [block]
  fragmentBlock _ block@(CodeBlock {})      = pure [block]
  fragmentBlock _ block@(RawBlock {})       = pure [block]
  fragmentBlock _ block@(DefinitionList {}) = pure [block]
  fragmentBlock _ block@(Table {})          = pure [block]
  fragmentBlock _ block@(Div {})            = pure [block]
  fragmentBlock _ block@HorizontalRule      = pure [block]
  fragmentBlock _ block@(LineBlock {})      = pure [block]
  fragmentBlock _ block@(Figure {})         = pure [block]
  fragmentBlock _ block@(VarBlock {})       = pure [block]
  fragmentBlock _ block@(SpeakerNote {})    = pure [block]
  fragmentBlock _ block@(Config {})         = pure [block]
  fragmentBlock _ block@(Reveal {})         = pure [block]  -- Should not happen
  
  fragmentList
      :: FragmentSettings   -- ^ Global settings
      -> Bool               -- ^ Fragment THIS list?
      -> RevealWrapper      -- ^ List constructor
      -> [[Block]]          -- ^ List items
      -> FragmentM [Block]  -- ^ Resulting list
  fragmentList fs fragmentThisList rw items0 = do
      items1 <- traverse (fragmentBlocks fs) items0
      case fragmentThisList of
          False -> pure $ revealWrapper rw items1
          True -> do
              revealID <- RevealID <$> state freshUnique
              let triggers = [c | s <- items1, c <- revealID : blocksRevealOrder s]
                  pauses   = length items1
              pure $ pure $ Reveal rw $ RevealSequence
                  revealID
                  triggers
                  [ (S.fromList [i .. pauses], s)
                  | (i, s) <- zip [1 ..] items1
                  ]
  
  -- Insert a final pause after any incremental lists.  This needs to happen
  -- on the list containing these blocks.
  fragmentAgainAfterLists :: [Block] -> FragmentM [Block]
  fragmentAgainAfterLists blocks = case splitAfterLists [] blocks of
      [] -> pure []
      [_] -> pure blocks
      sections@(_ : _) -> do
          revealID <- RevealID <$> state freshUnique
          let pauses = length sections - 1
              triggers = init
                  -- Use init to skip the final counter (we don't want to add
                  -- a pause at the very end since everything is displayed at
                  -- that point).
                  [c | s <- sections, c <- blocksRevealOrder s ++ [revealID]]
          pure $ pure $ Reveal ConcatWrapper $ RevealSequence
              revealID
              triggers
              [(S.fromList [i .. pauses + 1], s) | (i, s) <- zip [0 ..] sections]
    where
      splitAfterLists :: [Block] -> [Block] -> [[Block]]
      splitAfterLists acc [] = [reverse acc]
      splitAfterLists acc (b@(Reveal w _) : bs)
          | isListWrapper w, not (null bs) =
              reverse (b : acc) : splitAfterLists [] bs
      splitAfterLists acc (b : bs) = splitAfterLists (b : acc) bs
  
      isListWrapper BulletListWrapper = True
      isListWrapper (OrderedListWrapper _) = True
      isListWrapper ConcatWrapper = False
  