1{-# LANGUAGE RecordWildCards #-} 2{-# LANGUAGE LambdaCase #-} 3{-# LANGUAGE MultiWayIf #-} 4module Matterhorn.Draw.Messages 5 ( MessageData(..) 6 , renderMessage 7 , nameForUserRef 8 , renderSingleMessage 9 , unsafeRenderMessageSelection 10 , renderLastMessages 11 , addEllipsis 12 ) 13where 14 15import Brick 16import Brick.Widgets.Border 17import Control.Monad.Trans.Reader ( withReaderT ) 18import qualified Data.Foldable as F 19import qualified Data.Map.Strict as Map 20import qualified Data.Sequence as S 21import Data.Sequence ( ViewL(..) 22 , ViewR(..) 23 , (|>) 24 , viewl 25 , viewr) 26import qualified Data.Set as Set 27import qualified Data.Text as T 28import qualified Graphics.Vty as V 29import Lens.Micro.Platform ( (.~), to ) 30import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL ) 31import Network.Mattermost.Types ( ServerTime(..), userUsername, postId ) 32import Prelude () 33import Matterhorn.Prelude 34 35import Matterhorn.Draw.Util 36import Matterhorn.Draw.RichText 37import Matterhorn.Themes 38import Matterhorn.Types 39import Matterhorn.Types.RichText 40import Matterhorn.Types.DirectionalSeq 41 42maxMessageHeight :: Int 43maxMessageHeight = 200 44 45-- | nameForUserRef converts the UserRef into a printable name, based 46-- on the current known user data. 47nameForUserRef :: ChatState -> UserRef -> Maybe Text 48nameForUserRef st uref = 49 case uref of 50 NoUser -> Nothing 51 UserOverride _ t -> Just t 52 UserI _ uId -> displayNameForUserId uId st 53 54-- | renderSingleMessage is the main message drawing function. 55-- 56-- The `ind` argument specifies an "indicator boundary". Showing 57-- various indicators (e.g. "edited") is not typically done for 58-- messages that are older than this boundary value. 59renderSingleMessage :: ChatState 60 -> HighlightSet 61 -> Maybe ServerTime 62 -> Message 63 -> ThreadState 64 -> Widget Name 65renderSingleMessage st hs ind m threadState = 66 renderChatMessage st hs ind threadState (withBrackets . renderTime st . withServerTime) m 67 68renderChatMessage :: ChatState 69 -> HighlightSet 70 -> Maybe ServerTime 71 -> ThreadState 72 -> (ServerTime -> Widget Name) 73 -> Message 74 -> Widget Name 75renderChatMessage st hs ind threadState renderTimeFunc msg = 76 let showOlderEdits = configShowOlderEdits config 77 showTimestamp = configShowMessageTimestamps config 78 config = st^.csResources.crConfiguration 79 parent = case msg^.mInReplyToMsg of 80 NotAReply -> Nothing 81 InReplyTo pId -> getMessageForPostId st pId 82 m = renderMessage MessageData 83 { mdMessage = msg 84 , mdUserName = msg^.mUser.to (nameForUserRef st) 85 , mdParentMessage = parent 86 , mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st)) 87 , mdEditThreshold = ind 88 , mdHighlightSet = hs 89 , mdShowOlderEdits = showOlderEdits 90 , mdRenderReplyParent = True 91 , mdIndentBlocks = True 92 , mdThreadState = threadState 93 , mdShowReactions = True 94 , mdMessageWidthLimit = Nothing 95 , mdMyUsername = userUsername $ myUser st 96 , mdWrapNonhighlightedCodeBlocks = True 97 } 98 fullMsg = 99 case msg^.mUser of 100 NoUser 101 | isGap msg -> withDefAttr gapMessageAttr m 102 | otherwise -> 103 case msg^.mType of 104 C DateTransition -> 105 withDefAttr dateTransitionAttr (hBorderWithLabel m) 106 C NewMessagesTransition -> 107 withDefAttr newMessageTransitionAttr (hBorderWithLabel m) 108 C Error -> 109 withDefAttr errorMessageAttr m 110 _ -> 111 withDefAttr clientMessageAttr m 112 _ | isJoinLeave msg -> withDefAttr clientMessageAttr m 113 | otherwise -> m 114 maybeRenderTime w = 115 if showTimestamp 116 then let maybePadTime = if threadState == InThreadShowParent 117 then (txt " " <=>) else id 118 in hBox [maybePadTime $ renderTimeFunc (msg^.mDate), txt " ", w] 119 else w 120 maybeRenderTimeWith f = if isTransition msg then id else f 121 in maybeRenderTimeWith maybeRenderTime fullMsg 122 123-- | Render a selected message with focus, including the messages 124-- before and the messages after it. The foldable parameters exist 125-- because (depending on the situation) we might use either of the 126-- message list types for the 'before' and 'after' (i.e. the 127-- chronological or retrograde message sequences). 128unsafeRenderMessageSelection :: (SeqDirection dir1, SeqDirection dir2) 129 => ( (Message, ThreadState) 130 , ( DirectionalSeq dir1 (Message, ThreadState) 131 , DirectionalSeq dir2 (Message, ThreadState) 132 ) 133 ) 134 -> (Message -> ThreadState -> Widget Name) 135 -> Widget Name 136unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender = 137 Widget Greedy Greedy $ do 138 ctx <- getContext 139 curMsgResult <- withReaderT relaxHeight $ render $ 140 forceAttr messageSelectAttr $ 141 padRight Max $ doMsgRender curMsg curThreadState 142 143 let targetHeight = ctx^.availHeightL 144 upperHeight = targetHeight `div` 2 145 lowerHeight = targetHeight - upperHeight 146 147 lowerHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) vLimit after 148 upperHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) cropTopTo before 149 150 let upperHalfResultsHeight = sum $ (V.imageHeight . image) <$> upperHalfResults 151 lowerHalfResultsHeight = sum $ (V.imageHeight . image) <$> lowerHalfResults 152 curHeight = V.imageHeight $ curMsgResult^.imageL 153 uncropped = vBox $ fmap resultToWidget $ 154 (reverse upperHalfResults) <> (curMsgResult : lowerHalfResults) 155 156 cropTop h w = Widget Fixed Fixed $ do 157 result <- withReaderT relaxHeight $ render w 158 render $ cropTopTo h $ resultToWidget result 159 cropBottom h w = Widget Fixed Fixed $ do 160 result <- withReaderT relaxHeight $ render w 161 render $ cropBottomTo h $ resultToWidget result 162 163 lowerHalf = vBox $ fmap resultToWidget lowerHalfResults 164 upperHalf = vBox $ fmap resultToWidget $ reverse upperHalfResults 165 166 render $ if | lowerHalfResultsHeight < (lowerHeight - curHeight) -> 167 cropTop targetHeight uncropped 168 | upperHalfResultsHeight < upperHeight -> 169 vLimit targetHeight uncropped 170 | otherwise -> 171 cropTop upperHeight upperHalf <=> (resultToWidget curMsgResult) <=> 172 (if curHeight < lowerHeight 173 then cropBottom (lowerHeight - curHeight) lowerHalf 174 else cropBottom lowerHeight lowerHalf) 175 176resultToWidget :: Result n -> Widget n 177resultToWidget = Widget Fixed Fixed . return 178 179renderMessageSeq :: (SeqDirection dir) 180 => Int 181 -> (Message -> ThreadState -> Widget Name) 182 -> (Int -> Widget Name -> Widget Name) 183 -> DirectionalSeq dir (Message, ThreadState) 184 -> RenderM Name [Result Name] 185renderMessageSeq remainingHeight renderFunc limitFunc ms 186 | messagesLength ms == 0 = return [] 187 | otherwise = do 188 let Just (m, threadState) = messagesHead ms 189 maybeCache = case m^.mMessageId of 190 Nothing -> id 191 Just i -> cached (RenderedMessage i) 192 result <- render $ limitFunc remainingHeight $ maybeCache $ renderFunc m threadState 193 rest <- renderMessageSeq (remainingHeight - (V.imageHeight $ result^.imageL)) renderFunc limitFunc (messagesDrop 1 ms) 194 return $ result : rest 195 196renderLastMessages :: ChatState 197 -> HighlightSet 198 -> Maybe ServerTime 199 -> DirectionalSeq Retrograde (Message, ThreadState) 200 -> Widget Name 201renderLastMessages st hs editCutoff msgs = 202 Widget Greedy Greedy $ do 203 ctx <- getContext 204 let targetHeight = ctx^.availHeightL 205 doMsgRender = renderSingleMessage st hs editCutoff 206 207 newMessagesTransitions = filterMessages (isNewMessagesTransition . fst) msgs 208 newMessageTransition = fst <$> (listToMaybe $ F.toList newMessagesTransitions) 209 210 isBelow m transition = m^.mDate > transition^.mDate 211 212 go :: Int -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name [Result Name] 213 go _ ms | messagesLength ms == 0 = return [] 214 go remainingHeight ms = do 215 let Just (m, threadState) = messagesHead ms 216 newMessagesAbove = maybe False (isBelow m) newMessageTransition 217 218 result <- render $ render1 doMsgRender m threadState 219 220 croppedResult <- render $ cropTopTo remainingHeight $ resultToWidget result 221 222 -- If the new message fills the window, check whether 223 -- there is still a "New Messages" transition that is 224 -- not displayed. If there is, then we need to replace 225 -- the top line of the new image with a "New Messages" 226 -- indicator. 227 if V.imageHeight (result^.imageL) >= remainingHeight 228 then do 229 single <- if newMessagesAbove 230 then do 231 result' <- render $ 232 vBox [ withDefAttr newMessageTransitionAttr $ hBorderWithLabel (txt "New Messages ↑") 233 , cropTopBy 1 $ resultToWidget croppedResult 234 ] 235 return result' 236 else do 237 return croppedResult 238 return [single] 239 else do 240 let unusedHeight = remainingHeight - V.imageHeight (result^.imageL) 241 rest <- go unusedHeight $ messagesDrop 1 ms 242 return $ result : rest 243 244 results <- go targetHeight msgs 245 render $ vBox $ (Widget Fixed Fixed . return) <$> reverse results 246 247relaxHeight :: Context -> Context 248relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL)) 249 250render1 :: (Message -> ThreadState -> Widget Name) 251 -> Message 252 -> ThreadState 253 -> Widget Name 254render1 doMsgRender msg threadState = case msg^.mDeleted of 255 True -> emptyWidget 256 False -> 257 Widget Greedy Fixed $ do 258 withReaderT relaxHeight $ 259 render $ padRight Max $ 260 doMsgRender msg threadState 261 262-- | A bundled structure that includes all the information necessary 263-- to render a given message 264data MessageData = 265 MessageData { mdEditThreshold :: Maybe ServerTime 266 -- ^ If specified, any messages edited before this point 267 -- in time are not indicated as edited. 268 , mdShowOlderEdits :: Bool 269 -- ^ Indicates whether "edited" markers should be shown 270 -- for old messages (i.e., ignore the mdEditThreshold 271 -- value). 272 , mdShowReactions :: Bool 273 -- ^ Whether to render reactions. 274 , mdMessage :: Message 275 -- ^ The message to render. 276 , mdUserName :: Maybe Text 277 -- ^ The username of the message's author, if any. This 278 -- is passed here rather than obtaining from the message 279 -- because we need to do lookups in the ChatState to 280 -- compute this, and we don't pass the ChatState into 281 -- renderMessage. 282 , mdParentMessage :: Maybe Message 283 -- ^ The parent message of this message, if any. 284 , mdParentUserName :: Maybe Text 285 -- ^ The author of the parent message, if any. 286 , mdThreadState :: ThreadState 287 -- ^ The thread state of this message. 288 , mdRenderReplyParent :: Bool 289 -- ^ Whether to render the parent message. 290 , mdHighlightSet :: HighlightSet 291 -- ^ The highlight set to use to highlight usernames, 292 -- channel names, etc. 293 , mdIndentBlocks :: Bool 294 -- ^ Whether to indent the message underneath the 295 -- author's name (True) or just display it to the right 296 -- of the author's name (False). 297 , mdMessageWidthLimit :: Maybe Int 298 -- ^ A width override to use to wrap non-code blocks 299 -- and code blocks without syntax highlighting. If 300 -- unspecified, all blocks in the message will be 301 -- wrapped and truncated at the width specified by the 302 -- rendering context. If specified, all non-code blocks 303 -- will be wrapped at this width and highlighted code 304 -- blocks will be rendered using the context's width. 305 , mdMyUsername :: Text 306 -- ^ The username of the user running Matterhorn. 307 , mdWrapNonhighlightedCodeBlocks :: Bool 308 -- ^ Whether to wrap text in non-highlighted code 309 -- blocks. 310 } 311 312-- | renderMessage performs markdown rendering of the specified message. 313renderMessage :: MessageData -> Widget Name 314renderMessage md@MessageData { mdMessage = msg, .. } = 315 let msgUsr = case mdUserName of 316 Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u 317 Nothing -> Nothing 318 botElem = if isBotMessage msg then txt "[BOT]" else emptyWidget 319 mId = msg^.mMessageId 320 clickableAuthor un = case mId of 321 Nothing -> id 322 -- We use the index (-1) since indexes for clickable 323 -- usernames elsewhere in this message start at 0. 324 Just i -> clickable (ClickableUsernameInMessage i (-1) un) 325 nameElems = case msgUsr of 326 Just un 327 | isEmote msg -> 328 [ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN]" else "" 329 , txt $ (if msg^.mFlagged then "[!] " else "") <> "*" 330 , clickableAuthor un $ colorUsername mdMyUsername un un 331 , botElem 332 , txt " " 333 ] 334 | otherwise -> 335 [ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN] " else "" 336 , clickableAuthor un $ colorUsername mdMyUsername un un 337 , botElem 338 , txt $ (if msg^.mFlagged then "[!]" else "") <> ": " 339 ] 340 Nothing -> [] 341 342 -- Use the editing threshold to determine whether to append an 343 -- editing indication to this message. 344 maybeAugment bs = case msg^.mOriginalPost of 345 Nothing -> bs 346 Just p -> 347 if p^.postEditAtL > p^.postCreateAtL 348 then case mdEditThreshold of 349 Just cutoff | p^.postEditAtL >= cutoff -> 350 addEditSentinel (EEditSentinel True) bs 351 _ -> if mdShowOlderEdits 352 then addEditSentinel (EEditSentinel False) bs 353 else bs 354 else bs 355 356 augmentedText = unBlocks $ maybeAugment $ msg^.mText 357 msgWidget = 358 vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText : 359 catMaybes [msgAtch, msgReac] 360 replyIndent = Widget Fixed Fixed $ do 361 ctx <- getContext 362 -- NB: The amount subtracted here must be the total padding 363 -- added below (pad 1 + vBorder) 364 w <- render $ hLimit (ctx^.availWidthL - 2) msgWidget 365 render $ vLimit (V.imageHeight $ w^.imageL) $ 366 padRight (Pad 1) vBorder <+> (Widget Fixed Fixed $ return w) 367 msgAtch = if S.null (msg^.mAttachments) 368 then Nothing 369 else Just $ withDefAttr clientMessageAttr $ vBox 370 [ txt (" [attached: `" <> a^.attachmentName <> "`]") 371 | a <- toList (msg^.mAttachments) 372 ] 373 msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions) 374 then Nothing 375 else let renderR e us lst = 376 let n = Set.size us 377 in if | n == 1 -> makeReactionWidget e us (" [" <> e <> "]") : lst 378 | otherwise -> makeReactionWidget e us (" [" <> e <> " " <> T.pack (show n) <> "]") : lst 379 nonEmptyReactions = Map.filter (not . Set.null) $ msg^.mReactions 380 makeReactionWidget e us t = 381 let w = txt t in 382 maybe w (flip clickable w) $ makeName e us 383 hasAnyReactions = not $ null nonEmptyReactions 384 makeName e us = do 385 pid <- postId <$> msg^.mOriginalPost 386 Just $ ClickableReactionInMessage pid e us 387 reactionWidget = Widget Fixed Fixed $ do 388 ctx <- getContext 389 let lineW = ctx^.availWidthL 390 reacs <- mapM render $ Map.foldrWithKey renderR [] nonEmptyReactions 391 let reacLines :: [Result n] -> Int -> [Result n] -> [[Result n]] 392 reacLines l _ [] = if null l then [] else [l] 393 reacLines l w (r:rs) = 394 let rW = V.imageWidth $ r^.imageL 395 in if rW <= w 396 then reacLines (l <> [r]) (w - rW) rs 397 else 398 let rest = reacLines [] lineW rs 399 in l : [r] : rest 400 401 render $ vBox $ hBox <$> (fmap (fmap resultToWidget)) (reacLines [] lineW reacs) 402 in if hasAnyReactions 403 then Just $ withDefAttr emojiAttr $ txt " " <+> reactionWidget 404 else Nothing 405 withParent p = 406 case mdThreadState of 407 NoThread -> msgWidget 408 InThreadShowParent -> p <=> replyIndent 409 InThread -> replyIndent 410 in if not mdRenderReplyParent 411 then msgWidget 412 else case msg^.mInReplyToMsg of 413 NotAReply -> msgWidget 414 InReplyTo _ -> 415 case mdParentMessage of 416 Nothing -> withParent (str "[loading...]") 417 Just pm -> 418 let parentMsg = renderMessage md 419 { mdShowOlderEdits = False 420 , mdMessage = pm 421 , mdUserName = mdParentUserName 422 , mdParentMessage = Nothing 423 , mdRenderReplyParent = False 424 , mdIndentBlocks = False 425 } 426 in withParent (addEllipsis $ forceAttr replyParentAttr parentMsg) 427 428 where 429 layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq Block 430 -> ViewL Block -> Widget Name 431 layout hs w nameElems bs xs | length xs > 1 = multiLnLayout hs w nameElems bs 432 layout hs w nameElems bs (Blockquote {} :< _) = multiLnLayout hs w nameElems bs 433 layout hs w nameElems bs (CodeBlock {} :< _) = multiLnLayout hs w nameElems bs 434 layout hs w nameElems bs (HTMLBlock {} :< _) = multiLnLayout hs w nameElems bs 435 layout hs w nameElems bs (List {} :< _) = multiLnLayout hs w nameElems bs 436 layout hs w nameElems bs (Para inlns :< _) 437 | F.any breakCheck (unInlines inlns) = multiLnLayout hs w nameElems bs 438 layout hs w nameElems bs _ = nameNextToMessage hs w nameElems bs 439 440 multiLnLayout hs w nameElems bs = 441 if mdIndentBlocks 442 then vBox [ hBox nameElems 443 , hBox [txt " ", renderRichText mdMyUsername hs ((subtract 2) <$> w) 444 mdWrapNonhighlightedCodeBlocks (Just clickableNames) (Blocks bs)] 445 ] 446 else nameNextToMessage hs w nameElems bs 447 448 nameNextToMessage hs w nameElems bs = 449 Widget Fixed Fixed $ do 450 nameResult <- render $ hBox nameElems 451 let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w 452 render $ hBox [ Widget Fixed Fixed $ return nameResult 453 , renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks (Just clickableNames) (Blocks bs) 454 ] 455 456 breakCheck i = i `elem` [ELineBreak, ESoftBreak] 457 458 clickableNames i (EHyperlink u _) = 459 case msg^.mMessageId of 460 Just mId -> Just $ ClickableURLInMessage mId i $ LinkURL u 461 Nothing -> Nothing 462 clickableNames i (EUser name) = 463 case msg^.mMessageId of 464 Just mId -> Just $ ClickableUsernameInMessage mId i name 465 Nothing -> Nothing 466 clickableNames _ _ = Nothing 467 468-- Add the edit sentinel to the end of the last block in the sequence. 469-- If the last block is a paragraph, append it to that paragraph. 470-- Otherwise, append a new block so it appears beneath the last 471-- block-level element. 472addEditSentinel :: Inline -> Blocks -> Blocks 473addEditSentinel d (Blocks bs) = 474 case viewr bs of 475 EmptyR -> Blocks bs 476 (rest :> b) -> Blocks rest <> appendEditSentinel d b 477 478appendEditSentinel :: Inline -> Block -> Blocks 479appendEditSentinel sentinel b = 480 let s = Para (Inlines $ S.singleton sentinel) 481 in Blocks $ case b of 482 Para is -> S.singleton $ Para (Inlines $ unInlines is |> ESpace |> sentinel) 483 _ -> S.fromList [b, s] 484 485omittedUsernameType :: MessageType -> Bool 486omittedUsernameType = \case 487 CP Join -> True 488 CP Leave -> True 489 CP TopicChange -> True 490 _ -> False 491 492addEllipsis :: Widget a -> Widget a 493addEllipsis w = Widget (hSize w) (vSize w) $ do 494 ctx <- getContext 495 let aw = ctx^.availWidthL 496 result <- render w 497 let withEllipsis = (hLimit (aw - 3) $ vLimit 1 $ (Widget Fixed Fixed $ return result)) <+> 498 str "..." 499 if (V.imageHeight (result^.imageL) > 1) || (V.imageWidth (result^.imageL) == aw) then 500 render withEllipsis else 501 return result 502