InputPreview.hs

{-# LANGUAGE RankNTypes #-}
module Matterhorn.Draw.InputPreview
  ( inputPreview
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick
import           Brick.Widgets.Border
import           Brick.Widgets.Edit
import           Control.Arrow ( (>>>) )
import qualified Data.Text as T
import           Data.Text.Zipper ( insertChar, getText, gotoEOL )
import           Data.Time.Calendar ( fromGregorian )
import           Data.Time.Clock ( UTCTime(..) )
import qualified Graphics.Vty as Vty
import           Lens.Micro.Platform ( SimpleGetter, to )

import           Network.Mattermost.Types ( ServerTime(..), UserId, TeamId
                                          )

import           Matterhorn.Constants
import           Matterhorn.Draw.Messages
import           Matterhorn.Draw.RichText
import           Matterhorn.Themes
import           Matterhorn.Types
import           Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL )


inputPreview :: ChatState
             -> SimpleGetter ChatState (EditState Name)
             -> TeamId
             -> Name
             -> HighlightSet
             -> Widget Name
inputPreview st editWhich tId vpName hs
    | not $ st^.csResources.crConfiguration.configShowMessagePreviewL = emptyWidget
    | otherwise = thePreview
    where
    uId = myUserId st
    -- Insert a cursor sentinel into the input text just before
    -- rendering the preview. We use the inserted sentinel (which is
    -- not rendered) to get brick to ensure that the line the cursor is
    -- on is visible in the preview viewport. We put the sentinel at
    -- the *end* of the line because it will still influence markdown
    -- parsing and can create undesirable/confusing churn in the
    -- rendering while the cursor moves around. If the cursor is at the
    -- end of whatever line the user is editing, that is very unlikely
    -- to be a problem.
    curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $
                  st^.editWhich.esEditor.editContentsL
    eName = getName $ st^.editWhich.esEditor
    curStr = T.intercalate "\n" curContents
    overrideTy = case st^.editWhich.esEditMode of
        Editing _ ty -> Just ty
        _ -> Nothing
    baseUrl = serverBaseUrl st tId
    previewMsg = previewFromInput baseUrl overrideTy uId curStr
    thePreview = let noPreview = str "(No preview)"
                     msgPreview = case previewMsg of
                       Nothing -> noPreview
                       Just pm -> if T.null curStr
                                  then noPreview
                                  else prview pm $ getParentMessage st pm
                     tag = MessagePreviewViewport eName
                     prview m p = freezeBorders $
                                  renderMessage MessageData
                                  { mdMessage           = m
                                  , mdUserName          = m^.mUser.to (printableNameForUserRef st)
                                  , mdParentMessage     = p
                                  , mdParentUserName    = p >>= (^.mUser.to (printableNameForUserRef st))
                                  , mdHighlightSet      = hs
                                  , mdEditThreshold     = Nothing
                                  , mdShowOlderEdits    = False
                                  , mdRenderReplyParent = True
                                  , mdRenderReplyIndent = True
                                  , mdIndentBlocks      = True
                                  , mdThreadState       = NoThread
                                  , mdShowReactions     = True
                                  , mdMessageWidthLimit = Nothing
                                  , mdMyUsername        = myUsername st
                                  , mdMyUserId          = myUserId st
                                  , mdWrapNonhighlightedCodeBlocks = True
                                  , mdTruncateVerbatimBlocks = Nothing
                                  , mdClickableNameTag  = tag
                                  }
                 in (maybePreviewViewport vpName msgPreview) <=>
                    hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")

previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message
previewFromInput _ _ _ s | s == T.singleton cursorSentinel = Nothing
previewFromInput baseUrl overrideTy uId s =
    -- If it starts with a slash but not /me, this has no preview
    -- representation
    let isCommand = "/" `T.isPrefixOf` s
        isEmoteCmd = "/me " `T.isPrefixOf` s
        content = if isEmoteCmd
                  then T.stripStart $ T.drop 3 s
                  else s
        msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy
    in if isCommand && not isEmoteCmd
       then Nothing
       else Just $ Message { _mText          = parseMarkdown (Just baseUrl) content
                           , _mMarkdownSource = content
                           , _mUser          = UserI False uId
                           , _mDate          = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0
                           -- The date is not used for preview
                           -- rendering, but we need to provide one.
                           -- Ideally we'd just use today's date, but
                           -- the rendering function is pure so we
                           -- can't.
                           , _mType          = msgTy
                           , _mPending       = False
                           , _mDeleted       = False
                           , _mAttachments   = mempty
                           , _mInReplyToMsg  = NotAReply
                           , _mMessageId     = Nothing
                           , _mReactions     = mempty
                           , _mOriginalPost  = Nothing
                           , _mFlagged       = False
                           , _mPinned        = False
                           , _mChannelId     = Nothing
                           }

maybePreviewViewport :: Name -> Widget Name -> Widget Name
maybePreviewViewport n w =
    Widget Greedy Fixed $ do
        result <- render w
        case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of
            False -> return result
            True ->
                render $ vLimit previewMaxHeight $ viewport n Vertical $
                         (resultToWidget result)