{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ParallelListComp #-}
module Matterhorn.Draw.RichText
  ( renderRichText
  , renderText
  , renderText'
  , cursorSentinel
  , findVerbatimChunk
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick ( (<+>), Widget, hLimit, imageL
                       , render, Size(..), Widget(..)
                       )
import qualified Brick as B
import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Skylighting as BS
import           Control.Monad.Reader
import qualified Data.Foldable as F
import qualified Data.Sequence as S
import           Data.Sequence ( ViewL(..)
                               , (<|)
                               , viewl
                               )
import qualified Data.Text as T
import qualified Graphics.Vty as V
import qualified Skylighting.Core as Sky

import           Matterhorn.Constants ( normalChannelSigil, userSigil, editMarking )
import           Matterhorn.Draw.RichText.Flatten
import           Matterhorn.Draw.RichText.Wrap
import           Matterhorn.Themes
import           Matterhorn.Types ( HighlightSet(..), emptyHSet )
import           Matterhorn.Types.RichText


-- Cursor sentinel for tracking the user's cursor position in previews.
cursorSentinel :: Char
cursorSentinel = '‸'

-- Render markdown with username highlighting
renderRichText :: Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
renderRichText curUser hSet w doWrap (Blocks bs) =
    runReader (do
              blocks <- mapM renderBlock (addBlankLines bs)
              return $ B.vBox $ toList blocks)
              (DrawCfg { drawCurUser = curUser
                       , drawHighlightSet = hSet
                       , drawLineWidth = w
                       , drawDoLineWrapping = doWrap
                       })

-- Add blank lines only between adjacent elements of the same type, to
-- save space
addBlankLines :: Seq Block -> Seq Block
addBlankLines = go' . viewl
  where go' EmptyL = S.empty
        go' (x :< xs) = go x (viewl xs)
        go a (b :< rs)
            | sameBlockType a b = a <| blank <| go b (viewl rs)
            | otherwise         = a <| go b (viewl rs)
        go x EmptyL = S.singleton x
        blank = Para (Inlines $ S.singleton ESpace)

-- Render text to markdown without username highlighting or permalink
-- detection
renderText :: Text -> Widget a
renderText txt = renderText' Nothing "" emptyHSet txt

renderText' :: Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a
renderText' baseUrl curUser hSet t =
    renderRichText curUser hSet Nothing True $
        parseMarkdown baseUrl t

vBox :: F.Foldable f => f (Widget a) -> Widget a
vBox = B.vBox . toList

hBox :: F.Foldable f => f (Widget a) -> Widget a
hBox = B.hBox . toList

header :: Int -> Widget a
header n = B.txt (T.replicate n "#")

maybeHLimit :: Maybe Int -> Widget a -> Widget a
maybeHLimit Nothing w = w
maybeHLimit (Just i) w = hLimit i w

type M a = Reader DrawCfg a

data DrawCfg =
    DrawCfg { drawCurUser :: Text
            , drawHighlightSet :: HighlightSet
            , drawLineWidth :: Maybe Int
            , drawDoLineWrapping :: Bool
            }

renderBlock :: Block -> M (Widget a)
renderBlock (Para is) =
    renderInlines is
renderBlock (Header n is) = do
    headerTxt <- withReader (\c -> c { drawLineWidth = subtract 1 <$> drawLineWidth c }) $
                 renderInlines is
    return $ B.withDefAttr clientHeaderAttr $
        hBox [ B.padRight (B.Pad 1) $ header n
             , headerTxt
             ]
renderBlock (Blockquote bs) = do
    w <- asks drawLineWidth
    bws <- mapM renderBlock (unBlocks bs)
    return $ maybeHLimit w $ addQuoting $ vBox bws
renderBlock (List ty spacing bs) = do
    w <- asks drawLineWidth
    lst <- renderList ty spacing bs
    return $ maybeHLimit w lst
renderBlock (CodeBlock ci tx) = do
    hSet <- asks drawHighlightSet

    let f = maybe renderRawCodeBlock
                  (renderCodeBlock (hSyntaxMap hSet))
                  mSyntax
        mSyntax = do
            lang <- codeBlockLanguage ci
            Sky.lookupSyntax lang (hSyntaxMap hSet)
    f tx
renderBlock (HTMLBlock t) = do
    w <- asks drawLineWidth
    return $ maybeHLimit w $ textWithCursor t
renderBlock (HRule) = do
    w <- asks drawLineWidth
    return $ maybeHLimit w $ B.vLimit 1 (B.fill '*')

quoteChar :: Char
quoteChar = '>'

addQuoting :: B.Widget n -> B.Widget n
addQuoting w =
    B.Widget B.Fixed (B.vSize w) $ do
        ctx <- B.getContext
        childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w

        let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height
            height = V.imageHeight $ childResult^.B.imageL

        B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder
                          , B.Widget B.Fixed B.Fixed $ return childResult
                          ]

renderCodeBlock :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a)
renderCodeBlock syntaxMap syntax tx = do
    let result = Sky.tokenize cfg syntax tx
        cfg = Sky.TokenizerConfig syntaxMap False
    case result of
        Left _ -> renderRawCodeBlock tx
        Right tokLines -> do
            let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)
            return $ (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=>
                     (padding <+> BS.renderRawSource textWithCursor tokLines)

renderRawCodeBlock :: Text -> M (Widget a)
renderRawCodeBlock tx = do
    doWrap <- asks drawDoLineWrapping

    let hPolicy = if doWrap then Greedy else Fixed
    return $ B.withDefAttr codeAttr $
        Widget hPolicy Fixed $ do
            c <- B.getContext
            let theLines = expandEmpty <$> T.lines tx
                expandEmpty "" = " "
                expandEmpty s  = s
                wrapFunc = if doWrap then wrappedTextWithCursor
                                     else textWithCursor
            renderedText <- render (B.hLimit (c^.B.availWidthL - 3) $ B.vBox $
                                    wrapFunc <$> theLines)

            let textHeight = V.imageHeight $ renderedText^.imageL
                padding = B.padLeftRight 1 (B.vLimit textHeight B.vBorder)

            render $ padding <+> (Widget Fixed Fixed $ return renderedText)

renderInlines :: Inlines -> M (Widget a)
renderInlines es = do
    w <- asks drawLineWidth
    hSet <- asks drawHighlightSet
    curUser <- asks drawCurUser

    return $ B.Widget B.Fixed B.Fixed $ do
        ctx <- B.getContext
        let width = fromMaybe (ctx^.B.availWidthL) w
            ws    = fmap (renderWrappedLine curUser) $
                    mconcat $
                    (doLineWrapping width <$> (F.toList $ flattenInlineSeq hSet es))
        B.render (vBox ws)

renderList :: ListType -> ListSpacing -> Seq Blocks -> M (Widget a)
renderList ty _spacing bs = do
    let is = case ty of
          BulletList _ -> repeat ("• ")
          OrderedList s _ Period ->
            [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]
          OrderedList s _ OneParen ->
            [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ]
          OrderedList s _ TwoParens ->
            [ T.pack (show (n :: Int)) <> ")) " | n <- [s..] ]

    results <- forM (zip is $ unBlocks <$> (F.toList bs)) $ \(i, b) -> do
        blocks <- mapM renderBlock b
        return $ B.txt i <+> vBox blocks

    return $ vBox results

renderWrappedLine :: Text -> WrappedLine -> Widget a
renderWrappedLine curUser l = hBox $ F.toList $ renderFlattenedValue curUser <$> l

renderFlattenedValue :: Text -> FlattenedValue -> Widget a
renderFlattenedValue curUser (NonBreaking rs) =
    let renderLine = hBox . F.toList . fmap (renderFlattenedValue curUser)
    in vBox (F.toList $ renderLine <$> F.toList rs)
renderFlattenedValue curUser (SingleInline fi) = addHyperlink $ addStyles widget
    where
        val = fiValue fi
        mUrl = fiURL fi
        styles = fiStyles fi

        addStyles w = foldr addStyle w styles
        addStyle s =
            B.withDefAttr $ case s of
                Strong        -> clientStrongAttr
                Code          -> codeAttr
                Permalink     -> permalinkAttr
                Strikethrough -> strikeThroughAttr
                Emph          -> clientEmphAttr

        addHyperlink = case mUrl of
            Nothing -> id
            Just u -> B.withDefAttr urlAttr . B.hyperlink (unURL u)

        widget = case val of
            FSpace               -> B.txt " "
            FUser u              -> colorUsername curUser u $ userSigil <> u
            FChannel c           -> B.withDefAttr channelNameAttr $
                                    B.txt $ normalChannelSigil <> c
            FEmoji em            -> B.withDefAttr emojiAttr $
                                    B.txt $ ":" <> em <> ":"
            FText t              -> if t == T.singleton (cursorSentinel)
                                    then B.visible $ B.txt " "
                                    else textWithCursor t
            FEditSentinel recent -> let attr = if recent
                                               then editedRecentlyMarkingAttr
                                               else editedMarkingAttr
                                    in B.withDefAttr attr $ B.txt editMarking

textWithCursor :: Text -> Widget a
textWithCursor t
    | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t
    | otherwise = B.txt t

wrappedTextWithCursor :: Text -> Widget a
wrappedTextWithCursor t
    | T.any (== cursorSentinel) t = B.visible $ B.txtWrap $ removeCursor t
    | otherwise = B.txtWrap t

removeCursor :: Text -> Text
removeCursor = T.filter (/= cursorSentinel)