content: --------------------------------------------------------------------------------
  {-# LANGUAGE LambdaCase        #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards   #-}
  module Patat.Presentation.Display
      ( Display (..)
      , displayPresentation
      , displayPresentationError
      , dumpPresentation
      ) where
  
  
  --------------------------------------------------------------------------------
  import           Control.Monad                        (guard)
  import           Control.Monad.Identity               (runIdentity)
  import           Control.Monad.Writer                 (Writer, execWriter, tell)
  import qualified Data.Aeson.Extended                  as A
  import           Data.Char.WCWidth.Extended           (wcstrwidth)
  import           Data.Foldable                        (for_)
  import qualified Data.HashMap.Strict                  as HMS
  import qualified Data.List                            as L
  import           Data.Maybe                           (fromMaybe, maybeToList)
  import qualified Data.Sequence.Extended               as Seq
  import qualified Data.Text                            as T
  import           Patat.Presentation.Display.CodeBlock
  import           Patat.Presentation.Display.Internal
  import           Patat.Presentation.Display.Table
  import           Patat.Presentation.Internal
  import           Patat.Presentation.Settings
  import qualified Patat.Presentation.SpeakerNotes      as SpeakerNotes
  import           Patat.Presentation.Syntax
  import           Patat.PrettyPrint                    ((<$$>))
  import qualified Patat.PrettyPrint                    as PP
  import           Patat.Size
  import           Patat.Theme                          (Theme (..))
  import qualified Patat.Theme                          as Theme
  import           Prelude
  import qualified Text.Pandoc.Extended                 as Pandoc
  
  
  --------------------------------------------------------------------------------
  data Display = DisplayDoc PP.Doc | DisplayImage FilePath deriving (Show)
  
  
  --------------------------------------------------------------------------------
  -- | Display something within the presentation borders that draw the title and
  -- the active slide number and so on.
  displayWithBorders
      :: Size -> Presentation -> (DisplaySettings -> PP.Doc) -> PP.Doc
  displayWithBorders (Size rows columns) pres@Presentation {..} f =
      (if null title
          then mempty
          else
              let titleRemainder = columns - titleWidth - titleOffset
                  wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder in
          borders wrappedTitle <> PP.hardline) <>
      f ds <> PP.hardline <>
      PP.goToLine (rows - 2) <>
      borders (PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space) <>
      PP.hardline
    where
      -- Get terminal width/title
      settings     = activeSettings pres
      (sidx, _)    = pActiveFragment
      ds           = DisplaySettings
          { dsSize          = canvasSize
          , dsMargins       = margins settings
          , dsWrap          = fromMaybe NoWrap $ psWrap settings
          , dsTabStop       = maybe 4 A.unFlexibleNum $ psTabStop settings
          , dsOSC8          = fromMaybe False (psLinks settings >>= lsOSC8)
          , dsTheme         = fromMaybe Theme.defaultTheme (psTheme settings)
          , dsSyntaxMap     = pSyntaxMap
          , dsResolve       = \var -> fromMaybe [] $ HMS.lookup var pVars
          , dsRevealState   = revealState
          }
  
      revealState = case activeFragment pres of
          Just (ActiveContent _ _ c) -> c
          _                          -> mempty
  
      -- Compute title.
      breadcrumbs = fromMaybe [] $ Seq.safeIndex pBreadcrumbs sidx
      plainTitle  = PP.toString $ prettyInlines ds pTitle
      breadTitle  = mappend plainTitle $ mconcat
          [ s
          | b <- map (prettyInlines ds . snd) breadcrumbs
          , s <- [" > ", PP.toString b]
          ]
      title
          | not . fromMaybe True $ psBreadcrumbs settings = plainTitle
          | wcstrwidth breadTitle > columns               = plainTitle
          | otherwise                                     = breadTitle
  
      -- Dimensions of title.
      titleWidth  = wcstrwidth title
      titleOffset = (columns - titleWidth) `div` 2
      borders     = themed ds themeBorders
  
      -- Room left for content
      canvasSize = Size (rows - 3) columns
  
      -- Compute footer.
      active
          | fromMaybe True $ psSlideNumber settings = show (sidx + 1) ++ " / " ++ show (length pSlides)
          | otherwise                               = ""
      activeWidth  = wcstrwidth active
      author       = PP.toString (prettyInlines ds pAuthor)
      authorWidth  = wcstrwidth author
      middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2
  
  
  --------------------------------------------------------------------------------
  displayPresentation :: Size -> Presentation -> Display
  displayPresentation size pres@Presentation {..} =
       case activeFragment pres of
          Nothing -> DisplayDoc $ displayWithBorders size pres mempty
          Just (ActiveContent fragment _ _)
                  | Just _ <- psImages pSettings
                  , Just image <- onlyImage fragment ->
              DisplayImage $ T.unpack image
          Just (ActiveContent fragment _ _) -> DisplayDoc $
              displayWithBorders size pres $ \theme ->
                  prettyMargins theme fragment
          Just (ActiveTitle block) -> DisplayDoc $
              displayWithBorders size pres $ \ds ->
                  let auto = Margins {mTop = Auto, mRight = Auto, mLeft = Auto} in
                  prettyMargins ds {dsMargins = auto} [block]
    where
      -- Check if the fragment consists of "just a single image".  Discard
      -- headers.
      onlyImage (Header{} : bs) = onlyImage bs
      onlyImage bs = case bs of
          [Figure _ bs']                 -> onlyImage bs'
          [Para [Image _ _ (target, _)]] -> Just target
          _                              -> Nothing
  
  
  --------------------------------------------------------------------------------
  -- | Displays an error in the place of the presentation.  This is useful if we
  -- want to display an error but keep the presentation running.
  displayPresentationError :: Size -> Presentation -> String -> PP.Doc
  displayPresentationError size pres err = displayWithBorders size pres $ \ds ->
      themed ds themeStrong "Error occurred in the presentation:" <$$>
      "" <$$>
      (PP.string err)
  
  
  --------------------------------------------------------------------------------
  dumpPresentation :: Presentation -> IO ()
  dumpPresentation pres@Presentation {..} =
      PP.putDoc $ PP.removeControls $
      PP.vcat $ L.intercalate ["{slide}"] $
          map dumpSlide [0 .. length pSlides - 1]
    where
      dumpSlide :: Int -> [PP.Doc]
      dumpSlide i = do
          slide <- maybeToList $ getSlide i pres
          dumpSpeakerNotes slide <> L.intercalate ["{fragment}"]
              [ dumpFragment (i, j)
              | j <- [0 .. numFragments slide - 1]
              ]
  
      dumpSpeakerNotes :: Slide -> [PP.Doc]
      dumpSpeakerNotes slide = do
          guard (slideSpeakerNotes slide /= mempty)
          pure $ PP.text $ "{speakerNotes: " <>
              SpeakerNotes.toText (slideSpeakerNotes slide) <> "}"
  
      dumpFragment :: Index -> [PP.Doc]
      dumpFragment idx =
          case displayPresentation (getSize idx) pres {pActiveFragment = idx} of
              DisplayDoc   doc      -> [doc]
              DisplayImage filepath -> [PP.string $ "{image: " ++ filepath ++ "}"]
  
      getSize :: Index -> Size
      getSize idx =
          let settings = activeSettings pres {pActiveFragment = idx}
              sRows    = fromMaybe 24 $ A.unFlexibleNum <$> psRows settings
              sCols    = fromMaybe 72 $ A.unFlexibleNum <$> psColumns settings in
          Size {..}
  
  
  --------------------------------------------------------------------------------
  -- | Renders the given blocks, adding margins based on the settings and wrapping
  -- based on width.
  prettyMargins :: DisplaySettings -> [Block] -> PP.Doc
  prettyMargins ds blocks = vertical $
      map horizontal blocks ++
      case prettyReferences ds blocks of
          []   -> []
          refs ->
              let doc0        = PP.vcat refs
                  size@(r, _) = PP.dimensions doc0 in
              [(horizontalIndent size gmargins $ horizontalWrap gmargins doc0, r)]
    where
      Size rows columns = dsSize ds
      gmargins = dsMargins ds
  
      -- For every block, calculate the size based on its last fragment.
      blockSize block =
          let revealState = blocksRevealLastStep [block]
              bmargins    = marginsFor block
          in PP.dimensions $ deindent bmargins $ horizontalWrap bmargins $
              prettyBlock ds {dsRevealState = revealState} block
  
      -- Vertically align some blocks by adding spaces in front of it.
      -- We also take in the number of rows for every block so we don't
      -- need to recompute it.
      vertical :: [(PP.Doc, Int)] -> PP.Doc
      vertical docs0 = mconcat (replicate top PP.hardline) <> doc
        where
          top = case mTop gmargins of
              Auto      -> (rows - actual) `div` 2
              NotAuto x -> x
  
          docs1  = [verticalPad r d | (d, r) <- docs0]
          actual = sum $ L.intersperse 1 $ map snd docs1
          doc    = PP.vcat $ map fst docs1
  
      -- Vertically pad a doc by adding lines below it.
      -- Return the actual size as well as the padded doc.
      verticalPad :: Int -> PP.Doc -> (PP.Doc, Int)
      verticalPad desired doc0
          | actual >= rows = (doc0, actual)
          | otherwise      = (doc0 <> padding, desired)
        where
          (actual, _) = PP.dimensions doc0
          padding     = mconcat $ replicate (desired - actual) PP.hardline
  
      -- Render and horizontally align a block.  Also returns the desired rows.
      horizontal :: Block -> (PP.Doc, Int)
      horizontal b@(Reveal ConcatWrapper reveal) =
          -- Horizontally aligning a fragment with a ConcatWrapper is a special
          -- case, as we want to horizontal align all the things inside
          -- individually.
          let (fblocks, _) = unzip $ map horizontal $
                  revealToBlocks (dsRevealState ds) ConcatWrapper reveal in
          (PP.vcat fblocks, fst (blockSize b))
      horizontal block =
          let size@(r, _) = blockSize block
              bmargins    = marginsFor block in
          ( horizontalIndent size bmargins $ horizontalWrap bmargins $
              prettyBlock ds block
          , r
          )
  
      horizontalIndent :: (Int, Int) -> Margins -> PP.Doc -> PP.Doc
      horizontalIndent (_, dcols) dmargins@Margins {..} doc0 =
          PP.indent indentation indentation doc1
        where
          doc1 = deindent dmargins doc0
          left = case mLeft of
              NotAuto x -> x
              Auto      -> case mRight of
                  NotAuto _ -> 0
                  Auto      -> (columns - dcols) `div` 2
          indentation = PP.Indentation left mempty
  
      -- Strip leading spaces to horizontally align code blocks etc.
      deindent Margins {..} doc0 = case (mLeft, mRight) of
          (Auto, Auto) -> PP.deindent doc0
          _            -> doc0
  
      -- Rearranges lines to fit into the wrap settings.
      horizontalWrap :: Margins -> PP.Doc -> PP.Doc
      horizontalWrap Margins {..} doc0 = case dsWrap ds of
          NoWrap     -> doc0
          AutoWrap   -> PP.wrapAt (Just $ columns - right - left) doc0
          WrapAt col -> PP.wrapAt (Just col) doc0
        where
          right = case mRight of
              Auto      -> 0
              NotAuto x -> x
          left = case mLeft of
              Auto      -> 0
              NotAuto x -> x
  
      -- Find the right margins for the specific block.  Currently, only headers
      -- can have different margins.
      marginsFor :: Block -> Margins
      marginsFor (Header n _ _) = fromMaybe gmargins $ do
          align <- Theme.htAlign $ Theme.themeForHeader n (dsTheme ds)
          guard $ align == Theme.CenterHeaderAlign
          pure gmargins {mLeft = Auto, mRight = Auto}
      marginsFor _ = gmargins
  
  
  --------------------------------------------------------------------------------
  prettyBlock :: DisplaySettings -> Block -> PP.Doc
  
  prettyBlock ds (Plain inlines) = prettyInlines ds inlines
  
  prettyBlock ds (Para inlines) =
      prettyInlines ds inlines <> PP.hardline
  
  prettyBlock ds (Header n _ inlines) =
      themed ds style content <> PP.hardline <>
      (case underline of
          Just t | t /= "" ->
              themed ds style (PP.string $ take cols $ cycle $ T.unpack t) <>
              PP.hardline
          _ -> mempty)
    where
      prefix    = fromMaybe mempty $ Theme.htPrefix headerTheme
      content   = PP.text prefix <> prettyInlines ds inlines
      (_, cols) = PP.dimensions content
      underline = Theme.htUnderline headerTheme
  
      headerTheme = Theme.themeForHeader n (dsTheme ds)
  
      style _ = Theme.htStyle headerTheme
  
  prettyBlock ds (CodeBlock classes txt) =
      prettyCodeBlock ds classes txt
  
  prettyBlock ds (BulletList bss) = PP.vcat
      [ PP.indent
          (PP.Indentation 2 $ themed ds themeBulletList prefix)
          (PP.Indentation 4 mempty)
          (prettyBlocks ds' bs)
      | bs <- bss
      ] <> PP.hardline
    where
      prefix = PP.string [marker] <> " "
      marker = case T.unpack <$> themeBulletListMarkers theme of
          Just (x : _) -> x
          _            -> '-'
  
      -- Cycle the markers.
      theme  = dsTheme ds
      theme' = theme
          { themeBulletListMarkers =
              (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme
          }
      ds'    = ds {dsTheme = theme'}
  
  prettyBlock ds (OrderedList _ bss) = PP.vcat
      [ PP.indent
          (PP.Indentation 0 $ themed ds themeOrderedList $ PP.string prefix)
          (PP.Indentation 4 mempty)
          (prettyBlocks ds bs)
      | (prefix, bs) <- zip padded bss
      ] <> PP.hardline
    where
      padded  = [n ++ replicate (4 - length n) ' ' | n <- numbers]
      numbers =
          [ show i ++ "."
          | i <- [1 .. length bss]
          ]
  
  prettyBlock _ds (RawBlock _ t) = PP.text t <> PP.hardline
  
  prettyBlock _ds HorizontalRule = "---"
  
  prettyBlock ds (BlockQuote bs) =
      let quote = PP.Indentation 0 (themed ds themeBlockQuote "> ") in
      PP.indent quote quote (themed ds themeBlockQuote $ prettyBlocks ds bs)
  
  prettyBlock ds (DefinitionList terms) =
      PP.vcat $ map prettyDefinition terms
    where
      prettyDefinition (term, definitions) =
          themed ds themeDefinitionTerm (prettyInlines ds term) <$$>
          PP.hardline <> PP.vcat
          [ PP.indent
              (PP.Indentation 0 (themed ds themeDefinitionList ":   "))
              (PP.Indentation 4 mempty) $
              prettyBlocks ds (plainToPara definition)
          | definition <- definitions
          ]
  
      plainToPara :: [Block] -> [Block]
      plainToPara = map $ \case
          Plain inlines -> Para inlines
          block         -> block
  
  
  prettyBlock ds (Table caption aligns headers rows) =
      PP.wrapAt Nothing $
      prettyTableDisplay ds TableDisplay
          { tdCaption = prettyInlines ds caption
          , tdAligns  = map align aligns
          , tdHeaders = map (prettyBlocks ds) headers
          , tdRows    = map (map (prettyBlocks ds)) rows
          }
    where
      align Pandoc.AlignLeft    = PP.AlignLeft
      align Pandoc.AlignCenter  = PP.AlignCenter
      align Pandoc.AlignDefault = PP.AlignLeft
      align Pandoc.AlignRight   = PP.AlignRight
  
  prettyBlock ds (Div _attrs blocks) = prettyBlocks ds blocks
  
  prettyBlock ds (LineBlock inliness) =
      let ind = PP.Indentation 0 (themed ds themeLineBlock "| ") in
      PP.wrapAt Nothing $
      PP.indent ind ind $
      PP.vcat $
      map (prettyInlines ds) inliness
  
  prettyBlock ds (Figure _attr blocks) = prettyBlocks ds blocks
  
  prettyBlock ds (Reveal w fragment) = prettyBlocks ds $
      revealToBlocks (dsRevealState ds) w fragment
  
  prettyBlock ds (VarBlock var) = prettyBlocks ds $ dsResolve ds var
  
  prettyBlock _ (SpeakerNote _) = mempty
  prettyBlock _ (Config _) = mempty
  
  
  --------------------------------------------------------------------------------
  prettyBlocks :: DisplaySettings -> [Block] -> PP.Doc
  prettyBlocks ds = PP.vcat . map (prettyBlock ds)
  
  
  --------------------------------------------------------------------------------
  prettyInline :: DisplaySettings -> Inline -> PP.Doc
  
  prettyInline _ds Space = PP.space
  
  prettyInline _ds (Str str) = PP.text str
  
  prettyInline ds (Emph inlines) =
      themed ds themeEmph $
      prettyInlines ds inlines
  
  prettyInline ds (Strong inlines) =
      themed ds themeStrong $
      prettyInlines ds inlines
  
  prettyInline ds (Underline inlines) =
      themed ds themeUnderline $
      prettyInlines ds inlines
  
  prettyInline ds (Code _ txt) =
      themed ds themeCode $
      PP.text (" " <> txt <> " ")
  
  prettyInline ds link@(Link _attrs _text (target, _title))
      | Just (text, _, _) <- toReferenceLink link =
          let doc = Just $ prettyInlines ds text in
          "[" <> themed ds themeLinkText (hyperlink ds target doc) <> "]"
      | otherwise =
          "<" <> themed ds themeLinkTarget (hyperlink ds target Nothing) <> ">"
  
  prettyInline _ds SoftBreak = PP.softline
  
  prettyInline _ds LineBreak = PP.hardline
  
  prettyInline ds (Strikeout t) =
      "~~" <> themed ds themeStrikeout (prettyInlines ds t) <> "~~"
  
  prettyInline ds (Quoted Pandoc.SingleQuote t) =
      "'" <> themed ds themeQuoted (prettyInlines ds t) <> "'"
  prettyInline ds (Quoted Pandoc.DoubleQuote t) =
      "'" <> themed ds themeQuoted (prettyInlines ds t) <> "'"
  
  prettyInline ds (Math _ t) =
      themed ds themeMath (PP.text t)
  
  prettyInline ds (Image _attrs text (target, _title)) =
      "![" <> themed ds themeImageText (prettyInlines ds text) <> "](" <>
      themed ds themeImageTarget (PP.text target) <> ")"
  
  prettyInline _ (RawInline _ t) = PP.text t
  
  -- These elements aren't really supported.
  prettyInline ds  (Cite      _ t) = prettyInlines ds t
  prettyInline ds  (Span      _ t) = prettyInlines ds t
  prettyInline _   (Note        _) = mempty  -- TODO: support notes?
  prettyInline ds  (Superscript t) = prettyInlines ds t
  prettyInline ds  (Subscript   t) = prettyInlines ds t
  prettyInline ds  (SmallCaps   t) = prettyInlines ds t
  -- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported
  
  
  --------------------------------------------------------------------------------
  prettyInlines :: DisplaySettings -> [Inline] -> PP.Doc
  prettyInlines ds = mconcat . map (prettyInline ds)
  
  
  --------------------------------------------------------------------------------
  type Reference = ([Inline], T.Text, T.Text)
  
  
  --------------------------------------------------------------------------------
  prettyReferences :: DisplaySettings -> [Block] -> [PP.Doc]
  prettyReferences ds =
      map prettyReference . execWriter . dftBlocks (pure . pure) tellReference
    where
      tellReference :: Inline -> Writer [Reference] [Inline]
      tellReference inline = do
          for_ (toReferenceLink inline) (tell . pure)
          pure [inline]
  
      prettyReference :: Reference -> PP.Doc
      prettyReference (text, target, title) =
          "[" <>
          themed ds themeLinkText
              (prettyInlines ds $ newlineToSpace text) <>
          "]: " <>
          themed ds themeLinkTarget (PP.text target) <>
          (if T.null title
              then mempty
              else PP.space <> PP.text title)
  
      newlineToSpace :: [Inline] -> [Inline]
      newlineToSpace = runIdentity . dftInlines (pure . pure) work
        where
          work x = pure $ case x of
              SoftBreak -> [Space]
              LineBreak -> [Space]
              _         -> [x]
  
  
  --------------------------------------------------------------------------------
  toReferenceLink :: Inline -> Maybe Reference
  toReferenceLink (Link _attrs text (target, title))
      | [Str target] /= text = Just (text, target, title)
  toReferenceLink _ = Nothing
  
  
  --------------------------------------------------------------------------------
  hyperlink :: DisplaySettings -> T.Text -> Maybe PP.Doc -> PP.Doc
  hyperlink ds url Nothing
      | dsOSC8 ds = PP.hyperlink (T.unpack url) (PP.text url)
      | otherwise = PP.text url
  hyperlink ds url (Just doc)
      | dsOSC8 ds = PP.hyperlink (T.unpack url) doc
      | otherwise = doc
  