matterhorn-50200.19.0: src/Matterhorn/Draw/MessageInterface.hs
{-# LANGUAGE RankNTypes #-}
module Matterhorn.Draw.MessageInterface
( drawMessageInterface
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick
import Brick.Keybindings
import Brick.Focus ( withFocusRing )
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List ( listElements, listSelectedElement, renderList )
import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents )
import Data.Char ( isSpace, isPunctuation )
import qualified Data.Foldable as F
import Data.List ( intersperse )
import Data.Maybe ( fromJust )
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Zipper ( cursorPosition )
import Data.Time.Clock ( UTCTime(..) )
import Lens.Micro.Platform ( (.~), (^?!), to, view, Lens', Traversal', SimpleGetter )
import Network.Mattermost.Types ( ChannelId, Type(Direct, Group)
, ServerTime(..), TeamId, idString
)
import Matterhorn.Constants
import Matterhorn.Draw.Buttons
import Matterhorn.Draw.Messages
import Matterhorn.Draw.ManageAttachments
import Matterhorn.Draw.InputPreview
import Matterhorn.Draw.Util
import Matterhorn.Draw.RichText
import Matterhorn.Events.MessageSelect
import Matterhorn.Events.UrlSelect
import Matterhorn.State.MessageSelect
import Matterhorn.Themes
import Matterhorn.TimeUtils ( justAfter, justBefore )
import Matterhorn.Types
import Matterhorn.Types.DirectionalSeq ( emptyDirSeq )
import Matterhorn.Types.RichText
drawMessageInterface :: ChatState
-> HighlightSet
-> TeamId
-> Bool
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Bool
-> Widget Name
drawMessageInterface st hs tId showNewMsgLine which renderReplyIndent focused =
interfaceContents
where
inMsgSelect = st^.which.miMode == MessageSelect
eName = getName $ st^.which.miEditor.esEditor
region = MessageInterfaceMessages eName
previewVpName = MessagePreviewViewport eName
interfaceContents =
case st^.which.miMode of
Compose -> renderMessages False
MessageSelect -> renderMessages True
ShowUrlList -> drawUrlSelectWindow st hs which
SaveAttachment {} -> drawSaveAttachmentWindow st which
ManageAttachments -> drawAttachmentList st which
BrowseFiles -> drawFileBrowser st which
renderMessages inMsgSel =
vBox [ freezeBorders $
renderMessageListing st inMsgSel showNewMsgLine tId hs which renderReplyIndent region
, bottomBorder
, inputPreview st (which.miEditor) tId previewVpName hs
, inputArea st (which.miEditor) focused hs
]
bottomBorder =
if inMsgSelect
then messageSelectBottomBar st tId which
else hBox [ showAttachmentCount
, hBorder
, showTypingUsers
, showBusy
]
showBusy = case st^.csWorkerIsBusy of
Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)
Just Nothing -> hLimit 2 hBorder <+> txt "*"
Nothing -> emptyWidget
showTypingUsers =
let format = renderText' Nothing (myUsername st) hs Nothing
in case allTypingUsers (st^.which.miEditor.esEphemeral.eesTypingUsers) of
[] -> emptyWidget
[uId] | Just un <- usernameForUserId uId st ->
format $ "[" <> addUserSigil un <> " is typing]"
[uId1, uId2] | Just un1 <- usernameForUserId uId1 st
, Just un2 <- usernameForUserId uId2 st ->
format $ "[" <> addUserSigil un1 <> " and " <> addUserSigil un2 <> " are typing]"
_ -> format "[several people are typing]"
kc = st^.csResources.crConfiguration.configUserKeysL
showAttachmentCount =
let count = length $ listElements $ st^.which.miEditor.esAttachmentList
in if count == 0
then emptyWidget
else hBox [ hLimit 1 hBorder
, withDefAttr clientMessageAttr $
txt $ "(" <> (T.pack $ show count) <> " attachment" <>
(if count == 1 then "" else "s") <> "; "
, withDefAttr clientEmphAttr $
txt $ ppMaybeBinding (firstActiveBinding kc ShowAttachmentListEvent)
, txt " to manage)"
]
messageSelectBottomBar :: ChatState
-> TeamId
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
messageSelectBottomBar st tId which =
case getSelectedMessage which st of
Nothing -> emptyWidget
Just postMsg ->
let optionList = if null usableOptions
then txt "(no actions available for this message)"
else hBox $ intersperse (txt " ") usableOptions
usableOptions = mkOption <$> messageSelectionKeyOptions st tId which postMsg
mkOption (k, desc) = withDefAttr messageSelectStatusAttr (txt k) <+>
txt (":" <> desc)
in hBox [ hLimit 1 hBorder
, txt "["
, optionList
, txt "]"
, hBorder
]
messageSelectionKeyOptions :: ChatState
-> TeamId
-> Lens' ChatState (MessageInterface Name i)
-> Message
-> [(T.Text, T.Text)]
messageSelectionKeyOptions st tId which msg =
let ev = keyEventBindings st (messageSelectKeybindings tId which)
hasVerb = isJust (findVerbatimChunk (msg^.mText))
hasURLs = numURLs > 0
numURLs = Seq.length $ msgURLs msg
s = if numURLs == 1 then "" else "s"
openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s
getUsable (usable, key, label) = if usable then Just (key, label) else Nothing
options = [ ( not $ isGap msg
, ev YankWholeMessageEvent
, "yank-all"
)
, ( isFlaggable msg && not (msg^.mFlagged)
, ev FlagMessageEvent
, "flag"
)
, ( isFlaggable msg && msg^.mFlagged
, ev FlagMessageEvent
, "unflag"
)
, ( isReplyable msg
, ev OpenThreadEvent
, "thread"
)
, ( isPostMessage msg
, ev CopyPostLinkEvent
, "copy-link"
)
, ( isPinnable msg && not (msg^.mPinned)
, ev PinMessageEvent
, "pin"
)
, ( isPinnable msg && msg^.mPinned
, ev PinMessageEvent
, "unpin"
)
, ( isReplyable msg
, ev ReplyMessageEvent
, "reply"
)
, ( not $ isGap msg
, ev ViewMessageEvent
, "view"
)
, ( not $ isGap msg
, ev OpenMessageInExternalEditorEvent
, "open"
)
, ( isGap msg
, ev FillGapEvent
, "load messages"
)
, ( isMine st msg && isEditable msg
, ev EditMessageEvent
, "edit"
)
, ( isMine st msg && isDeletable msg
, ev DeleteMessageEvent
, "delete"
)
, ( hasURLs
, ev OpenMessageURLEvent
, openUrlsMsg
)
, ( hasVerb
, ev YankMessageEvent
, "yank-code"
)
, ( isReactable msg
, ev ReactToMessageEvent
, "react"
)
]
in catMaybes $ getUsable <$> options
renderMessageListing :: ChatState
-> Bool
-> Bool
-> TeamId
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Name
-> Widget Name
renderMessageListing st inMsgSelect showNewMsgLine tId hs which renderReplyIndent region =
messages
where
mcId = st^.(csCurrentChannelId tId)
messages = padTop Max chatText
chatText =
case mcId of
Nothing -> fill ' '
Just cId ->
if inMsgSelect
then freezeBorders $
renderMessagesWithSelect cId (st^.which.miMessageSelect) (buildMessages cId)
else cached region $
freezeBorders $
renderLastMessages st hs (getEditedMessageCutoff cId st) renderReplyIndent region $
retrogradeMsgsWithThreadStates $
reverseMessages $
buildMessages cId
renderMessagesWithSelect cId (MessageSelectState selMsgId) msgs =
-- In this case, we want to fill the message list with messages
-- but use the post ID as a cursor. To do this efficiently we
-- only want to render enough messages to fill the screen.
--
-- If the message area is H rows high, this actually renders at
-- most 2H rows' worth of messages and then does the appropriate
-- cropping. This way we can simplify the math needed to figure
-- out how to crop while bounding the number of messages we
-- render around the cursor.
--
-- First, we sanity-check the application state because under
-- some conditions, the selected message might be gone (e.g.
-- deleted).
let (s, (before, after)) = splitDirSeqOn (\(m, _) -> m^.mMessageId == selMsgId) msgsWithStates
msgsWithStates = chronologicalMsgsWithThreadStates msgs
in case s of
Nothing ->
renderLastMessages st hs (getEditedMessageCutoff cId st) renderReplyIndent region before
Just m ->
unsafeRenderMessageSelection (m, (before, after))
(renderSingleMessage st hs renderReplyIndent Nothing) region
buildMessages cId =
-- If the message list is empty, add an informative message to
-- the message listing to make it explicit that this listing is
-- empty.
let cutoff = if showNewMsgLine
then getNewMessageCutoff cId st
else Nothing
ms = filterMessageListing st (which.miMessages)
in if F.null ms
then addMessage (emptyChannelFillerMessage st cId) emptyDirSeq
else insertTransitions ms
cutoff
(getDateFormat st)
(st ^. timeZone)
insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages
insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT
where anyNondeletedNewMessages t =
isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms)
newMessagesT = case cutoff of
Nothing -> []
Just Hide -> []
Just (NewPostsAfterServerTime t)
| anyNondeletedNewMessages t -> [newMessagesMsg $ justAfter t]
| otherwise -> []
Just (NewPostsStartingAt t)
| anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t]
| otherwise -> []
newMessagesMsg d = newMessageOfType (T.pack "New Messages")
(C NewMessagesTransition) d
-- | Construct a single message to be displayed in the specified channel
-- when it does not yet have any user messages posted to it.
emptyChannelFillerMessage :: ChatState -> ChannelId -> Message
emptyChannelFillerMessage st cId =
newMessageOfType msg (C Informative) ts
where
-- This is a bogus timestamp, but its value does not matter
-- because it is only used to create a message that will be
-- shown in a channel with no date transitions (which would
-- otherwise include this bogus date) or other messages (which
-- would make for a broken message sorting).
ts = ServerTime $ UTCTime (toEnum 0) 0
chan = fromJust $ findChannelById cId (st^.csChannels)
chanName = mkChannelName st (chan^.ccInfo)
msg = case chan^.ccInfo.cdType of
Direct ->
let u = chan^.ccInfo.cdDMUserId >>= flip userById st
in case u of
Nothing -> userMsg Nothing
Just _ -> userMsg (Just chanName)
Group ->
groupMsg (chan^.ccInfo.cdDisplayName)
_ ->
chanMsg chanName
userMsg (Just cn) = "You have not yet sent any direct messages to " <> cn <> "."
userMsg Nothing = "You have not yet sent any direct messages to this user."
groupMsg us = "There are not yet any direct messages in the group " <> us <> "."
chanMsg cn = "There are not yet any messages in the " <> cn <> " channel."
filterMessageListing :: ChatState -> Traversal' ChatState Messages -> Messages
filterMessageListing st msgsWhich =
st ^?! msgsWhich . to (filterMessages isShown)
where isShown m
| st^.csResources.crUserPreferences.userPrefShowJoinLeave = True
| otherwise = not $ isJoinLeave m
inputArea :: ChatState
-> Lens' ChatState (EditState Name)
-> Bool
-> HighlightSet
-> Widget Name
inputArea st which focused hs =
let replyPrompt = "reply> "
normalPrompt = "> "
editPrompt = "edit> "
showReplyPrompt = st^.which.esShowReplyPrompt
maybeHighlight = if focused
then withDefAttr focusedEditorPromptAttr
else id
prompt = maybeHighlight $
reportExtent (MessageInputPrompt $ getName editor) $
txt $ case st^.which.esEditMode of
Replying {} ->
if showReplyPrompt then replyPrompt else normalPrompt
Editing {} ->
editPrompt
NewPost ->
normalPrompt
editor = st^.which.esEditor
inputBox = renderEditor (drawEditorContents st which hs) True editor
curContents = getEditContents editor
multilineContent = length curContents > 1
multilineHints =
hBox [ hLimit 1 hBorder
, str $ "[" <> (show $ (+1) $ fst $ cursorPosition $
editor^.editContentsL) <>
"/" <> (show $ length curContents) <> "]"
, hBorderWithLabel $ withDefAttr clientEmphAttr $
txt $ "In multi-line mode. Press " <> multiLineToggleKey <>
" to finish."
]
replyDisplay = case st^.which.esEditMode of
Replying msg _ | showReplyPrompt ->
let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply
in hBox [ replyArrow
, addEllipsis $ renderMessage MessageData
{ mdMessage = msgWithoutParent
, mdUserName = msgWithoutParent^.mUser.to (printableNameForUserRef st)
, mdParentMessage = Nothing
, mdParentUserName = Nothing
, mdHighlightSet = hs
, mdEditThreshold = Nothing
, mdShowOlderEdits = False
, mdRenderReplyParent = True
, mdRenderReplyIndent = True
, mdIndentBlocks = False
, mdThreadState = NoThread
, mdShowReactions = True
, mdMessageWidthLimit = Nothing
, mdMyUsername = myUsername st
, mdMyUserId = myUserId st
, mdWrapNonhighlightedCodeBlocks = True
, mdTruncateVerbatimBlocks = Nothing
, mdClickableNameTag = getName editor
}
]
_ -> emptyWidget
kc = st^.csResources.crConfiguration.configUserKeysL
multiLineToggleKey = ppMaybeBinding $ firstActiveBinding kc ToggleMultiLineEvent
commandBox = case st^.which.esEphemeral.eesMultiline of
False ->
let linesStr = "line" <> if numLines == 1 then "" else "s"
numLines = length curContents
in vLimit 1 $ hBox $
prompt : if multilineContent
then [ withDefAttr clientEmphAttr $
str $ "[" <> show numLines <> " " <> linesStr <>
"; Enter: send, " <> T.unpack multiLineToggleKey <>
": edit, Backspace: cancel] "
, txt $ head curContents
, showCursor (getName editor) (Location (0,0)) $ str " "
]
else [inputBox]
True -> vLimit multilineHeightLimit inputBox <=> multilineHints
in replyDisplay <=> commandBox
drawEditorContents :: ChatState
-> SimpleGetter ChatState (EditState Name)
-> HighlightSet
-> [Text]
-> Widget Name
drawEditorContents st editWhich hs =
let noHighlight = txt . T.unlines
ms = st^.editWhich.esMisspellings
in case S.null ms of
True -> noHighlight
False -> doHighlightMisspellings hs ms
replyArrow :: Widget a
replyArrow =
Widget Fixed Fixed $ do
ctx <- getContext
let bs = ctx^.ctxBorderStyleL
render $ str [' ', bsCornerTL bs, '▸']
-- | Tokens in spell check highlighting.
data Token =
Ignore Text
-- ^ This bit of text is to be ignored for the purposes of
-- spell-checking.
| Check Text
-- ^ This bit of text should be checked against the spell checker's
-- misspelling list.
deriving (Show)
-- | This function takes a set of misspellings from the spell
-- checker, the editor lines, and builds a rendering of the text with
-- misspellings highlighted.
--
-- This function processes each line of text from the editor as follows:
--
-- * Tokenize the line based on our rules for what constitutes
-- whitespace. We do this because we need to check "words" in the
-- user's input against the list of misspellings returned by the spell
-- checker. But to do this we need to ignore the same things that
-- Aspell ignores, and it ignores whitespace and lots of puncutation.
-- We also do this because once we have identified the misspellings
-- present in the input, we need to reconstruct the user's input and
-- that means preserving whitespace so that the input looks as it was
-- originally typed.
--
-- * Once we have a list of tokens -- the whitespace tokens to be
-- preserved but ignored and the tokens to be checked -- we check
-- each non-whitespace token for presence in the list of misspellings
-- reported by the checker.
--
-- * Having indicated which tokens correspond to misspelled words, we
-- then need to coallesce adjacent tokens that are of the same
-- "misspelling status", i.e., two neighboring tokens (of whitespace
-- or check type) need to be coallesced if they both correspond to
-- text that is a misspelling or if they both are NOT a misspelling.
-- We do this so that the final Brick widget is optimal in that it
-- uses a minimal number of box cells to display substrings that have
-- the same attribute.
--
-- * Finally we build a widget out of these coallesced tokens and apply
-- the misspellingAttr attribute to the misspelled tokens.
--
-- Note that since we have to come to our own conclusion about which
-- words are worth checking in the checker's output, sometimes our
-- algorithm will differ from aspell in what is considered "part of a
-- word" and what isn't. In particular, Aspell is smart about sometimes
-- noticing that "'" is an apostrophe and at other times that it is
-- a single quote as part of a quoted string. As a result there will
-- be cases where Markdown formatting characters interact poorly
-- with Aspell's checking to result in misspellings that are *not*
-- highlighted.
--
-- One way to deal with this would be to *not* parse the user's input
-- as done here, complete with all its Markdown metacharacters, but to
-- instead 1) parse the input as Markdown, 2) traverse the Markdown AST
-- and extract the words from the relevant subtrees, and 3) spell-check
-- those words. The reason we don't do it that way in the first place is
-- because 1) the user's input might not be valid markdown and 2) even
-- if we did that, we'd still have to do this tokenization operation to
-- annotate misspellings and reconstruct the user's raw input.
doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name
doHighlightMisspellings hs misspellings contents =
-- Traverse the input, gathering non-whitespace into tokens and
-- checking if they appear in the misspelling collection
let whitelist = S.union (hUserSet hs) (hChannelSet hs)
handleLine t | t == "" = txt " "
handleLine t =
-- For annotated tokens, coallesce tokens of the same type
-- and add attributes for misspellings.
let mkW (Left tok) =
let s = getTokenText tok
in if T.null s
then emptyWidget
else withDefAttr misspellingAttr $ txt $ getTokenText tok
mkW (Right tok) =
let s = getTokenText tok
in if T.null s
then emptyWidget
else txt s
go :: Either Token Token -> [Either Token Token] -> [Either Token Token]
go lst [] = [lst]
go lst (tok:toks) =
case (lst, tok) of
(Left a, Left b) -> go (Left $ combineTokens a b) toks
(Right a, Right b) -> go (Right $ combineTokens a b) toks
_ -> lst : go tok toks
in hBox $ mkW <$> (go (Right $ Ignore "") $ annotatedTokens t)
combineTokens (Ignore a) (Ignore b) = Ignore $ a <> b
combineTokens (Check a) (Check b) = Check $ a <> b
combineTokens (Ignore a) (Check b) = Check $ a <> b
combineTokens (Check a) (Ignore b) = Check $ a <> b
getTokenText (Ignore a) = a
getTokenText (Check a) = a
annotatedTokens t =
-- For every token, check on whether it is a misspelling.
-- The result is Either Token Token where the Left is a
-- misspelling and the Right is not.
checkMisspelling <$> tokenize t (Ignore "")
checkMisspelling t@(Ignore _) = Right t
checkMisspelling t@(Check s) =
if s `S.member` whitelist
then Right t
else if s `S.member` misspellings
then Left t
else Right t
ignoreChar c = isSpace c || isPunctuation c || c == '`' || c == '/' ||
T.singleton c == userSigil || T.singleton c == normalChannelSigil
tokenize t curTok
| T.null t = [curTok]
| ignoreChar $ T.head t =
case curTok of
Ignore s -> tokenize (T.tail t) (Ignore $ s <> (T.singleton $ T.head t))
Check s -> Check s : tokenize (T.tail t) (Ignore $ T.singleton $ T.head t)
| otherwise =
case curTok of
Ignore s -> Ignore s : tokenize (T.tail t) (Check $ T.singleton $ T.head t)
Check s -> tokenize (T.tail t) (Check $ s <> (T.singleton $ T.head t))
in vBox $ handleLine <$> contents
drawSaveAttachmentWindow :: ChatState
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
drawSaveAttachmentWindow st which =
center $
padAll 2 $
borderWithLabel (withDefAttr clientEmphAttr $ txt "Save Attachment") $
vBox [ padAll 1 $
txt "Path: " <+>
(vLimit editorHeight $
withFocusRing foc (renderEditor drawEditorTxt) ed)
, hBox [ padRight Max $
padLeft (Pad 1) $
drawButton foc (AttachmentPathSaveButton listName) "Save"
, padRight (Pad 1) $
drawButton foc (AttachmentPathCancelButton listName) "Cancel"
]
]
where
editorHeight = 1
listName = getName $ st^.which.miUrlList.ulList
foc = st^.which.miSaveAttachmentDialog.attachmentPathDialogFocus
ed = st^.which.miSaveAttachmentDialog.attachmentPathEditor
drawEditorTxt = txt . T.unlines
drawUrlSelectWindow :: ChatState -> HighlightSet -> Lens' ChatState (MessageInterface Name i) -> Widget Name
drawUrlSelectWindow st hs which =
vBox [ renderUrlList st hs which
, urlSelectBottomBar st which
, urlSelectInputArea st which
]
renderUrlList :: ChatState -> HighlightSet -> Lens' ChatState (MessageInterface Name i) -> Widget Name
renderUrlList st hs which =
urlDisplay
where
urlDisplay = if F.length urls == 0
then str "No links found." <=> fill ' '
else renderList renderItem True urls
urls = st^.which.miUrlList.ulList
me = myUsername st
renderItem sel (i, link) =
let time = link^.linkTime
in attr sel $ vLimit 2 $
(vLimit 1 $
hBox [ let u = maybe "<server>" id (link^.linkUser.to (printableNameForUserRef st))
in colorUsername me u u
, case link^.linkLabel of
Nothing -> emptyWidget
Just label ->
case Seq.null (unInlines label) of
True -> emptyWidget
False -> txt ": " <+> renderRichText me hs Nothing False Nothing Nothing
(Blocks $ Seq.singleton $ Para label)
, fill ' '
, renderDate st $ withServerTime time
, str " "
, renderTime st $ withServerTime time
] ) <=>
(vLimit 1 (clickable (ClickableURLListEntry i (link^.linkTarget)) $ renderLinkTarget (link^.linkTarget)))
renderLinkTarget (LinkPermalink (TeamURLName tName) pId) =
renderText $ "Team: " <> tName <> ", post " <> idString pId
renderLinkTarget (LinkURL url) = renderText $ unURL url
renderLinkTarget (LinkFileId _) = txt " "
attr True = forceAttr urlListSelectedAttr
attr False = id
urlSelectBottomBar :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectBottomBar st which =
case listSelectedElement $ st^.which.miUrlList.ulList of
Nothing -> hBorder
Just (_, (_, link)) ->
let options = [ ( isFile
, ev SaveAttachmentEvent
, "save attachment"
)
]
ev = keyEventBindings st (urlSelectKeybindings which)
isFile entry = case entry^.linkTarget of
LinkFileId {} -> True
_ -> False
optionList = hBox $ intersperse (txt " ") usableOptions
usableOptions = catMaybes $ mkOption <$> options
mkOption (f, k, desc) = if f link
then Just $ withDefAttr urlSelectStatusAttr (txt k) <+>
txt (":" <> desc)
else Nothing
in if null usableOptions
then hBorder
else hBox [ hLimit 1 hBorder
, txt "["
, txt "Options: "
, optionList
, txt "]"
, hBorder
]
urlSelectInputArea :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectInputArea st which =
let getBinding = keyEventBindings st (urlSelectKeybindings which)
in hCenter $ hBox [ withDefAttr clientEmphAttr $ txt "Enter"
, txt ":open "
, withDefAttr clientEmphAttr $ txt $ getBinding CancelEvent
, txt ":close"
]