matterhorn-50200.12.0: src/Matterhorn/Draw/Messages.hs
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Matterhorn.Draw.Messages
( MessageData(..)
, renderMessage
, nameForUserRef
, renderSingleMessage
, unsafeRenderMessageSelection
, renderLastMessages
, addEllipsis
)
where
import Brick
import Brick.Widgets.Border
import Control.Monad.Trans.Reader ( withReaderT )
import qualified Data.Foldable as F
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as S
import Data.Sequence ( ViewL(..)
, ViewR(..)
, (|>)
, viewl
, viewr)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Graphics.Vty as V
import Lens.Micro.Platform ( (.~), to )
import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )
import Network.Mattermost.Types ( ServerTime(..), userUsername )
import Prelude ()
import Matterhorn.Prelude
import Matterhorn.Draw.Util
import Matterhorn.Draw.RichText
import Matterhorn.Themes
import Matterhorn.Types
import Matterhorn.Types.RichText
import Matterhorn.Types.DirectionalSeq
maxMessageHeight :: Int
maxMessageHeight = 200
-- | nameForUserRef converts the UserRef into a printable name, based
-- on the current known user data.
nameForUserRef :: ChatState -> UserRef -> Maybe Text
nameForUserRef st uref =
case uref of
NoUser -> Nothing
UserOverride _ t -> Just t
UserI _ uId -> displayNameForUserId uId st
-- | renderSingleMessage is the main message drawing function.
--
-- The `ind` argument specifies an "indicator boundary". Showing
-- various indicators (e.g. "edited") is not typically done for
-- messages that are older than this boundary value.
renderSingleMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> Message
-> ThreadState
-> Widget Name
renderSingleMessage st hs ind m threadState =
renderChatMessage st hs ind threadState (withBrackets . renderTime st . withServerTime) m
renderChatMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> (ServerTime -> Widget Name)
-> Message
-> Widget Name
renderChatMessage st hs ind threadState renderTimeFunc msg =
let showOlderEdits = configShowOlderEdits config
showTimestamp = configShowMessageTimestamps config
config = st^.csResources.crConfiguration
parent = case msg^.mInReplyToMsg of
NotAReply -> Nothing
InReplyTo pId -> getMessageForPostId st pId
m = renderMessage MessageData
{ mdMessage = msg
, mdUserName = msg^.mUser.to (nameForUserRef st)
, mdParentMessage = parent
, mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st))
, mdEditThreshold = ind
, mdHighlightSet = hs
, mdShowOlderEdits = showOlderEdits
, mdRenderReplyParent = True
, mdIndentBlocks = True
, mdThreadState = threadState
, mdShowReactions = True
, mdMessageWidthLimit = Nothing
, mdMyUsername = userUsername $ myUser st
, mdWrapNonhighlightedCodeBlocks = True
}
fullMsg =
case msg^.mUser of
NoUser
| isGap msg -> withDefAttr gapMessageAttr m
| otherwise ->
case msg^.mType of
C DateTransition ->
withDefAttr dateTransitionAttr (hBorderWithLabel m)
C NewMessagesTransition ->
withDefAttr newMessageTransitionAttr (hBorderWithLabel m)
C Error ->
withDefAttr errorMessageAttr m
_ ->
withDefAttr clientMessageAttr m
_ | isJoinLeave msg -> withDefAttr clientMessageAttr m
| otherwise -> m
maybeRenderTime w =
if showTimestamp
then let maybePadTime = if threadState == InThreadShowParent
then (txt " " <=>) else id
in hBox [maybePadTime $ renderTimeFunc (msg^.mDate), txt " ", w]
else w
maybeRenderTimeWith f = if isTransition msg then id else f
in maybeRenderTimeWith maybeRenderTime fullMsg
-- | Render a selected message with focus, including the messages
-- before and the messages after it. The foldable parameters exist
-- because (depending on the situation) we might use either of the
-- message list types for the 'before' and 'after' (i.e. the
-- chronological or retrograde message sequences).
unsafeRenderMessageSelection :: (Foldable f, Foldable g)
=> ((Message, ThreadState), (f (Message, ThreadState), g (Message, ThreadState)))
-> (Message -> ThreadState -> Widget Name)
-> Widget Name
unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender =
Widget Greedy Greedy $ do
ctx <- getContext
curMsgResult <- withReaderT relaxHeight $ render $
forceAttr messageSelectAttr $
padRight Max $ doMsgRender curMsg curThreadState
let targetHeight = ctx^.availHeightL
upperHeight = targetHeight `div` 2
lowerHeight = targetHeight - upperHeight
lowerRender img (m, tState) = render1HLimit doMsgRender V.vertJoin targetHeight img tState m
upperRender img (m, tState) = render1HLimit doMsgRender (flip V.vertJoin) targetHeight img tState m
lowerHalf <- foldM lowerRender V.emptyImage after
upperHalf <- foldM upperRender V.emptyImage before
let curHeight = V.imageHeight $ curMsgResult^.imageL
uncropped = upperHalf V.<-> curMsgResult^.imageL V.<-> lowerHalf
img = if | V.imageHeight lowerHalf < (lowerHeight - curHeight) ->
V.cropTop targetHeight uncropped
| V.imageHeight upperHalf < upperHeight ->
V.cropBottom targetHeight uncropped
| otherwise ->
V.cropTop upperHeight upperHalf V.<-> curMsgResult^.imageL V.<->
(if curHeight < lowerHeight
then V.cropBottom (lowerHeight - curHeight) lowerHalf
else V.cropBottom lowerHeight lowerHalf)
return $ emptyResult & imageL .~ img
renderLastMessages :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages st hs editCutoff msgs =
Widget Greedy Greedy $ do
ctx <- getContext
let targetHeight = ctx^.availHeightL
doMsgRender = renderSingleMessage st hs editCutoff
newMessagesTransitions = filterMessages (isNewMessagesTransition . fst) msgs
newMessageTransition = fst <$> (listToMaybe $ F.toList newMessagesTransitions)
isBelow m transition = m^.mDate > transition^.mDate
go :: V.Image -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name V.Image
go img ms | messagesLength ms == 0 = return img
go img ms = do
let Just (m, threadState) = messagesHead ms
newMessagesAbove = maybe False (isBelow m) newMessageTransition
newImg <- render1HLimit doMsgRender (flip V.vertJoin) targetHeight img threadState m
-- If the new message fills the window, check whether
-- there is still a "New Messages" transition that is
-- not displayed. If there is, then we need to replace
-- the top line of the new image with a "New Messages"
-- indicator.
if V.imageHeight newImg >= targetHeight && newMessagesAbove
then do
transitionResult <- render $ withDefAttr newMessageTransitionAttr $
hBorderWithLabel (txt "New Messages ↑")
let newImg2 = V.vertJoin (transitionResult^.imageL)
(V.cropTop (targetHeight - 1) newImg)
return newImg2
else go newImg $ messagesDrop 1 ms
img <- go V.emptyImage msgs
return $ emptyResult & imageL .~ (V.cropTop targetHeight img)
relaxHeight :: Context -> Context
relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))
render1HLimit :: (Message -> ThreadState -> Widget Name)
-> (V.Image -> V.Image -> V.Image)
-> Int
-> V.Image
-> ThreadState
-> Message
-> RenderM Name V.Image
render1HLimit doMsgRender fjoin lim img threadState msg
| V.imageHeight img >= lim = return img
| otherwise = fjoin img <$> render1 doMsgRender threadState msg
render1 :: (Message -> ThreadState -> Widget Name)
-> ThreadState
-> Message
-> RenderM Name V.Image
render1 doMsgRender threadState msg = case msg^.mDeleted of
True -> return V.emptyImage
False -> do
r <- withReaderT relaxHeight $
render $ padRight Max $
doMsgRender msg threadState
return $ r^.imageL
-- | A bundled structure that includes all the information necessary
-- to render a given message
data MessageData =
MessageData { mdEditThreshold :: Maybe ServerTime
-- ^ If specified, any messages edited before this point
-- in time are not indicated as edited.
, mdShowOlderEdits :: Bool
-- ^ Indicates whether "edited" markers should be shown
-- for old messages (i.e., ignore the mdEditThreshold
-- value).
, mdShowReactions :: Bool
-- ^ Whether to render reactions.
, mdMessage :: Message
-- ^ The message to render.
, mdUserName :: Maybe Text
-- ^ The username of the message's author, if any. This
-- is passed here rather than obtaining from the message
-- because we need to do lookups in the ChatState to
-- compute this, and we don't pass the ChatState into
-- renderMessage.
, mdParentMessage :: Maybe Message
-- ^ The parent message of this message, if any.
, mdParentUserName :: Maybe Text
-- ^ The author of the parent message, if any.
, mdThreadState :: ThreadState
-- ^ The thread state of this message.
, mdRenderReplyParent :: Bool
-- ^ Whether to render the parent message.
, mdHighlightSet :: HighlightSet
-- ^ The highlight set to use to highlight usernames,
-- channel names, etc.
, mdIndentBlocks :: Bool
-- ^ Whether to indent the message underneath the
-- author's name (True) or just display it to the right
-- of the author's name (False).
, mdMessageWidthLimit :: Maybe Int
-- ^ A width override to use to wrap non-code blocks
-- and code blocks without syntax highlighting. If
-- unspecified, all blocks in the message will be
-- wrapped and truncated at the width specified by the
-- rendering context. If specified, all non-code blocks
-- will be wrapped at this width and highlighted code
-- blocks will be rendered using the context's width.
, mdMyUsername :: Text
-- ^ The username of the user running Matterhorn.
, mdWrapNonhighlightedCodeBlocks :: Bool
-- ^ Whether to wrap text in non-highlighted code
-- blocks.
}
-- | renderMessage performs markdown rendering of the specified message.
renderMessage :: MessageData -> Widget Name
renderMessage md@MessageData { mdMessage = msg, .. } =
let msgUsr = case mdUserName of
Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u
Nothing -> Nothing
botElem = if isBotMessage msg then txt "[BOT]" else emptyWidget
nameElems = case msgUsr of
Just un
| isEmote msg ->
[ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN]" else ""
, txt $ (if msg^.mFlagged then "[!] " else "") <> "*"
, colorUsername mdMyUsername un un
, botElem
, txt " "
]
| otherwise ->
[ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN] " else ""
, colorUsername mdMyUsername un un
, botElem
, txt $ (if msg^.mFlagged then "[!]" else "") <> ": "
]
Nothing -> []
-- Use the editing threshold to determine whether to append an
-- editing indication to this message.
maybeAugment bs = case msg^.mOriginalPost of
Nothing -> bs
Just p ->
if p^.postEditAtL > p^.postCreateAtL
then case mdEditThreshold of
Just cutoff | p^.postEditAtL >= cutoff ->
addEditSentinel (EEditSentinel True) bs
_ -> if mdShowOlderEdits
then addEditSentinel (EEditSentinel False) bs
else bs
else bs
augmentedText = unBlocks $ maybeAugment $ msg^.mText
msgWidget =
vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText :
catMaybes [msgAtch, msgReac]
replyIndent = Widget Fixed Fixed $ do
ctx <- getContext
-- NB: The amount subtracted here must be the total padding
-- added below (pad 1 + vBorder)
w <- render $ hLimit (ctx^.availWidthL - 2) msgWidget
render $ vLimit (V.imageHeight $ w^.imageL) $
padRight (Pad 1) vBorder <+> (Widget Fixed Fixed $ return w)
msgAtch = if S.null (msg^.mAttachments)
then Nothing
else Just $ withDefAttr clientMessageAttr $ vBox
[ txt (" [attached: `" <> a^.attachmentName <> "`]")
| a <- toList (msg^.mAttachments)
]
msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions)
then Nothing
else let renderR e us =
let n = Set.size us
in if | n == 1 -> " [" <> e <> "]"
| n > 1 -> " [" <> e <> " " <> T.pack (show n) <> "]"
| otherwise -> ""
reactionMsg = Map.foldMapWithKey renderR (msg^.mReactions)
in Just $ withDefAttr emojiAttr $ txt (" " <> reactionMsg)
withParent p =
case mdThreadState of
NoThread -> msgWidget
InThreadShowParent -> p <=> replyIndent
InThread -> replyIndent
in if not mdRenderReplyParent
then msgWidget
else case msg^.mInReplyToMsg of
NotAReply -> msgWidget
InReplyTo _ ->
case mdParentMessage of
Nothing -> withParent (str "[loading...]")
Just pm ->
let parentMsg = renderMessage md
{ mdShowOlderEdits = False
, mdMessage = pm
, mdUserName = mdParentUserName
, mdParentMessage = Nothing
, mdRenderReplyParent = False
, mdIndentBlocks = False
}
in withParent (addEllipsis $ forceAttr replyParentAttr parentMsg)
where
layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq Block
-> ViewL Block -> Widget Name
layout hs w nameElems bs xs | length xs > 1 = multiLnLayout hs w nameElems bs
layout hs w nameElems bs (Blockquote {} :< _) = multiLnLayout hs w nameElems bs
layout hs w nameElems bs (CodeBlock {} :< _) = multiLnLayout hs w nameElems bs
layout hs w nameElems bs (HTMLBlock {} :< _) = multiLnLayout hs w nameElems bs
layout hs w nameElems bs (List {} :< _) = multiLnLayout hs w nameElems bs
layout hs w nameElems bs (Para inlns :< _)
| F.any breakCheck (unInlines inlns) = multiLnLayout hs w nameElems bs
layout hs w nameElems bs _ = nameNextToMessage hs w nameElems bs
multiLnLayout hs w nameElems bs =
if mdIndentBlocks
then vBox [ hBox nameElems
, hBox [txt " ", renderRichText mdMyUsername hs ((subtract 2) <$> w)
mdWrapNonhighlightedCodeBlocks (Blocks bs)]
]
else nameNextToMessage hs w nameElems bs
nameNextToMessage hs w nameElems bs =
Widget Fixed Fixed $ do
nameResult <- render $ hBox nameElems
let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w
render $ hBox [ raw (nameResult^.imageL)
, renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks (Blocks bs)
]
breakCheck i = i `elem` [ELineBreak, ESoftBreak]
-- Add the edit sentinel to the end of the last block in the sequence.
-- If the last block is a paragraph, append it to that paragraph.
-- Otherwise, append a new block so it appears beneath the last
-- block-level element.
addEditSentinel :: Inline -> Blocks -> Blocks
addEditSentinel d (Blocks bs) =
case viewr bs of
EmptyR -> Blocks bs
(rest :> b) -> Blocks rest <> appendEditSentinel d b
appendEditSentinel :: Inline -> Block -> Blocks
appendEditSentinel sentinel b =
let s = Para (Inlines $ S.singleton sentinel)
in Blocks $ case b of
Para is -> S.singleton $ Para (Inlines $ unInlines is |> ESpace |> sentinel)
_ -> S.fromList [b, s]
omittedUsernameType :: MessageType -> Bool
omittedUsernameType = \case
CP Join -> True
CP Leave -> True
CP TopicChange -> True
_ -> False
addEllipsis :: Widget a -> Widget a
addEllipsis w = Widget (hSize w) (vSize w) $ do
ctx <- getContext
let aw = ctx^.availWidthL
result <- render w
let withEllipsis = (hLimit (aw - 3) $ vLimit 1 $ (Widget Fixed Fixed $ return result)) <+>
str "..."
if (V.imageHeight (result^.imageL) > 1) || (V.imageWidth (result^.imageL) == aw) then
render withEllipsis else
return result