{-# LANGUAGE MultiWayIf #-}
module Matterhorn.Draw.Main (drawMain) where
import Prelude ()
import Matterhorn.Prelude
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center ( hCenter )
import Brick.Widgets.List ( listElements )
import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents )
import Control.Arrow ( (>>>) )
import Data.Char ( isSpace, isPunctuation )
import Data.List ( intersperse )
import qualified Data.Map as M
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Zipper ( cursorPosition, insertChar, getText, gotoEOL )
import Data.Time.Calendar ( fromGregorian )
import Data.Time.Clock ( UTCTime(..) )
import qualified Graphics.Vty as Vty
import Lens.Micro.Platform ( (.~), (^?!), to, view, folding )
import Network.Mattermost.Types ( ChannelId, Type(Direct, Private, Group)
, ServerTime(..), UserId
)
import Matterhorn.Constants
import Matterhorn.Draw.ChannelList ( renderChannelList, renderChannelListHeader )
import Matterhorn.Draw.Messages
import Matterhorn.Draw.Autocomplete
import Matterhorn.Draw.URLList
import Matterhorn.Draw.Util
import Matterhorn.Draw.RichText
import Matterhorn.Events.Keybindings
import Matterhorn.Events.MessageSelect
import Matterhorn.State.MessageSelect
import Matterhorn.Themes
import Matterhorn.TimeUtils ( justAfter, justBefore )
import Matterhorn.Types
import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL )
import Matterhorn.Types.KeyEvents
previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message
previewFromInput _ _ _ s | s == T.singleton cursorSentinel = Nothing
previewFromInput baseUrl overrideTy uId s =
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
, _mType = msgTy
, _mPending = False
, _mDeleted = False
, _mAttachments = mempty
, _mInReplyToMsg = NotAReply
, _mMessageId = Nothing
, _mReactions = mempty
, _mOriginalPost = Nothing
, _mFlagged = False
, _mPinned = False
, _mChannelId = Nothing
}
data Token =
Ignore Text
| Check Text
deriving (Show)
drawEditorContents :: ChatState -> HighlightSet -> [Text] -> Widget Name
drawEditorContents st hs =
let noHighlight = txt . T.unlines
in case st^.csEditState.cedSpellChecker of
Nothing -> noHighlight
Just _ ->
case S.null (st^.csEditState.cedMisspellings) of
True -> noHighlight
False -> doHighlightMisspellings
hs
(st^.csEditState.cedMisspellings)
doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name
doHighlightMisspellings hSet misspellings contents =
let whitelist = S.union (hUserSet hSet) (hChannelSet hSet)
handleLine t | t == "" = txt " "
handleLine t =
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 =
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
renderUserCommandBox :: ChatState -> HighlightSet -> Widget Name
renderUserCommandBox st hs =
let prompt = txt $ case st^.csEditState.cedEditMode of
Replying _ _ -> "reply> "
Editing _ _ -> "edit> "
NewPost -> "> "
inputBox = renderEditor (drawEditorContents st hs) True (st^.csEditState.cedEditor)
curContents = getEditContents $ st^.csEditState.cedEditor
multilineContent = length curContents > 1
multilineHints =
hBox [ borderElem bsHorizontal
, str $ "[" <> (show $ (+1) $ fst $ cursorPosition $
st^.csEditState.cedEditor.editContentsL) <>
"/" <> (show $ length curContents) <> "]"
, hBorderWithLabel $ withDefAttr clientEmphAttr $
txt $ "In multi-line mode. Press " <> multiLineToggleKey <>
" to finish."
]
replyDisplay = case st^.csEditState.cedEditMode of
Replying msg _ ->
let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply
in hBox [ replyArrow
, addEllipsis $ renderMessage MessageData
{ mdMessage = msgWithoutParent
, mdUserName = msgWithoutParent^.mUser.to (nameForUserRef st)
, mdParentMessage = Nothing
, mdParentUserName = Nothing
, mdHighlightSet = hs
, mdEditThreshold = Nothing
, mdShowOlderEdits = False
, mdRenderReplyParent = True
, mdIndentBlocks = False
, mdThreadState = NoThread
, mdShowReactions = True
, mdMessageWidthLimit = Nothing
, mdMyUsername = myUsername st
, mdWrapNonhighlightedCodeBlocks = True
}
]
_ -> emptyWidget
multiLineToggleKey = ppBinding $ getFirstDefaultBinding ToggleMultiLineEvent
commandBox = case st^.csEditState.cedEphemeral.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 MessageInput (Location (0,0)) $ str " "
]
else [inputBox]
True -> vLimit multilineHeightLimit inputBox <=> multilineHints
in replyDisplay <=> commandBox
renderChannelHeader :: ChatState -> HighlightSet -> ClientChannel -> Widget Name
renderChannelHeader st hs chan =
let chnType = chan^.ccInfo.cdType
topicStr = chan^.ccInfo.cdHeader
userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts
parts = [ chanName
, if (all T.null names)
then mempty
else "is"
] <> names <> [
if T.null (u^.uiEmail)
then mempty
else "(" <> u^.uiEmail <> ")"
]
names = [ u^.uiFirstName
, nick
, u^.uiLastName
]
quote n = "\"" <> n <> "\""
nick = maybe "" quote $ u^.uiNickName
in s
firstTopicLine = case T.lines topicStr of
[h] -> h
(h:_:_) -> h
_ -> ""
maybeTopic = if T.null topicStr
then ""
else " - " <> if st^.csShowExpandedChannelTopics
then topicStr
else firstTopicLine
channelNameString = case chnType of
Direct ->
case chan^.ccInfo.cdDMUserId >>= flip userById st of
Nothing -> chanName
Just u -> userHeader u
Private ->
channelNamePair <> " (Private)"
Group ->
channelNamePair <> " (Private group)"
_ ->
channelNamePair
channelNamePair = chanName <> " - " <> (chan^.ccInfo.cdDisplayName)
chanName = mkChannelName st (chan^.ccInfo)
baseUrl = serverBaseUrl st
in renderText' (Just baseUrl) (myUsername st)
hs
(channelNameString <> maybeTopic)
renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name
renderCurrentChannelDisplay st hs = header <=> hBorder <=> messages
where
header =
if st^.csShowChannelList
then channelHeader
else headerWithStatus
headerWithStatus =
Widget Fixed Fixed $ do
ctx <- getContext
statusBox <- render $
hLimit (configChannelListWidth $ st^.csResources.crConfiguration) $
(renderChannelListHeader st)
let channelHeaderWidth = ctx^.availWidthL -
(Vty.imageWidth $ statusBox^.imageL) - 1
channelHeaderResult <- render $ hLimit channelHeaderWidth channelHeader
let maxHeight = max (Vty.imageHeight $ statusBox^.imageL)
(Vty.imageHeight $ channelHeaderResult^.imageL)
statusBoxWidget = Widget Fixed Fixed $ return statusBox
headerWidget = Widget Fixed Fixed $ return channelHeaderResult
borderWidget = vLimit maxHeight vBorder
render $ if appMode st == ChannelSelect
then headerWidget
else hBox $ case st^.csChannelListOrientation of
ChannelListLeft ->
[ statusBoxWidget
, borderWidget
, headerWidget
]
ChannelListRight ->
[ headerWidget
, borderWidget
, statusBoxWidget
]
channelHeader =
withDefAttr channelHeaderAttr $
padRight Max $
renderChannelHeader st hs chan
messages = padTop Max chatText
chatText = case appMode st of
MessageSelect ->
renderMessagesWithSelect (st^.csMessageSelect) channelMessages
MessageSelectDeleteConfirm ->
renderMessagesWithSelect (st^.csMessageSelect) channelMessages
_ ->
cached (ChannelMessages cId) $
renderLastMessages st hs editCutoff $
retrogradeMsgsWithThreadStates $
reverseMessages channelMessages
renderMessagesWithSelect (MessageSelectState selMsgId) msgs =
let (s, (before, after)) = splitDirSeqOn (\(m, _) -> m^.mMessageId == selMsgId) msgsWithStates
msgsWithStates = chronologicalMsgsWithThreadStates msgs
in case s of
Nothing ->
renderLastMessages st hs editCutoff before
Just m ->
unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st hs Nothing)
cutoff = getNewMessageCutoff cId st
editCutoff = getEditedMessageCutoff cId st
channelMessages =
insertTransitions (getMessageListing cId st)
cutoff
(getDateFormat st)
(st ^. timeZone)
cId = st^.csCurrentChannelId
chan = st^.csCurrentChannel
getMessageListing :: ChannelId -> ChatState -> Messages
getMessageListing cId st =
st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown)
where isShown m
| st^.csResources.crUserPreferences.userPrefShowJoinLeave = True
| otherwise = not $ isJoinLeave m
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
renderChannelSelectPrompt :: ChatState -> Widget Name
renderChannelSelectPrompt st =
let e = st^.csChannelSelectState.channelSelectInput
in withDefAttr channelSelectPromptAttr $
(txt "Switch to channel [use ^ and $ to anchor]: ") <+>
(renderEditor (txt . T.concat) True e)
drawMain :: Bool -> ChatState -> [Widget Name]
drawMain useColor st =
let maybeColor = if useColor then id else forceAttr "invalid"
in maybeColor <$>
[ connectionLayer st
, autocompleteLayer st
, joinBorders $ mainInterface st
]
connectionLayer :: ChatState -> Widget Name
connectionLayer st =
case st^.csConnectionStatus of
Connected -> emptyWidget
Disconnected ->
Widget Fixed Fixed $ do
ctx <- getContext
let aw = ctx^.availWidthL
w = length msg + 2
msg = "NOT CONNECTED"
render $ translateBy (Location (max 0 (aw - w), 0)) $
withDefAttr errorMessageAttr $
border $ str msg
messageSelectBottomBar :: ChatState -> Widget Name
messageSelectBottomBar st =
case getSelectedMessage 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 = catMaybes $ mkOption <$> options
mkOption (f, k, desc) = if f postMsg
then Just $ withDefAttr messageSelectStatusAttr (txt k) <+>
txt (":" <> desc)
else Nothing
numURLs = Seq.length $ msgURLs postMsg
s = if numURLs == 1 then "" else "s"
hasURLs = numURLs > 0
openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s
hasVerb = isJust (findVerbatimChunk (postMsg^.mText))
ev e =
let keyconf = st^.csResources.crConfiguration.to configUserKeys
KeyHandlerMap keymap = messageSelectKeybindings keyconf
in T.intercalate ","
[ ppBinding (eventToBinding k)
| KH { khKey = k
, khHandler = h
} <- M.elems keymap
, kehEventTrigger h == ByEvent e
]
options = [ ( not . isGap
, ev YankWholeMessageEvent
, "yank-all"
)
, ( \m -> isFlaggable m && not (m^.mFlagged)
, ev FlagMessageEvent
, "flag"
)
, ( \m -> isFlaggable m && m^.mFlagged
, ev FlagMessageEvent
, "unflag"
)
, ( \m -> isPinnable m && not (m^.mPinned)
, ev PinMessageEvent
, "pin"
)
, ( \m -> isPinnable m && m^.mPinned
, ev PinMessageEvent
, "unpin"
)
, ( isReplyable
, ev ReplyMessageEvent
, "reply"
)
, ( not . isGap
, ev ViewMessageEvent
, "view"
)
, ( isGap
, ev FillGapEvent
, "load messages"
)
, ( \m -> isMine st m && isEditable m
, ev EditMessageEvent
, "edit"
)
, ( \m -> isMine st m && isDeletable m
, ev DeleteMessageEvent
, "delete"
)
, ( const hasURLs
, ev OpenMessageURLEvent
, openUrlsMsg
)
, ( const hasVerb
, ev YankMessageEvent
, "yank-code"
)
, ( isReactable
, ev ReactToMessageEvent
, "react"
)
]
in hBox [ borderElem bsHorizontal
, txt "["
, txt "Message select: "
, optionList
, txt "]"
, hBorder
]
maybePreviewViewport :: Widget Name -> Widget Name
maybePreviewViewport w =
Widget Greedy Fixed $ do
result <- render w
case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of
False -> return result
True ->
render $ vLimit previewMaxHeight $ viewport MessagePreviewViewport Vertical $
(Widget Fixed Fixed $ return result)
inputPreview :: ChatState -> HighlightSet -> Widget Name
inputPreview st hs | not $ st^.csShowMessagePreview = emptyWidget
| otherwise = thePreview
where
uId = myUserId st
curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $
st^.csEditState.cedEditor.editContentsL
curStr = T.intercalate "\n" curContents
overrideTy = case st^.csEditState.cedEditMode of
Editing _ ty -> Just ty
_ -> Nothing
baseUrl = serverBaseUrl st
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
prview m p = renderMessage MessageData
{ mdMessage = m
, mdUserName = m^.mUser.to (nameForUserRef st)
, mdParentMessage = p
, mdParentUserName = p >>= (^.mUser.to (nameForUserRef st))
, mdHighlightSet = hs
, mdEditThreshold = Nothing
, mdShowOlderEdits = False
, mdRenderReplyParent = True
, mdIndentBlocks = True
, mdThreadState = NoThread
, mdShowReactions = True
, mdMessageWidthLimit = Nothing
, mdMyUsername = myUsername st
, mdWrapNonhighlightedCodeBlocks = True
}
in (maybePreviewViewport msgPreview) <=>
hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")
userInputArea :: ChatState -> HighlightSet -> Widget Name
userInputArea st hs =
case appMode st of
ChannelSelect -> renderChannelSelectPrompt st
UrlSelect -> hCenter $ hBox [ txt "Press "
, withDefAttr clientEmphAttr $ txt "Enter"
, txt " to open the selected URL or "
, withDefAttr clientEmphAttr $ txt "Escape"
, txt " to cancel."
]
MessageSelectDeleteConfirm -> renderDeleteConfirm
_ -> renderUserCommandBox st hs
renderDeleteConfirm :: Widget Name
renderDeleteConfirm =
hCenter $ txt "Are you sure you want to delete the selected message? (y/n)"
mainInterface :: ChatState -> Widget Name
mainInterface st =
vBox [ body
, bottomBorder
, inputPreview st hs
, userInputArea st hs
]
where
body = if st^.csShowChannelList || appMode st == ChannelSelect
then case st^.csChannelListOrientation of
ChannelListLeft ->
hBox [channelList, vBorder, mainDisplay]
ChannelListRight ->
hBox [mainDisplay, vBorder, channelList]
else mainDisplay
channelList = hLimit channelListWidth (renderChannelList st)
hs = getHighlightSet st
channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration
mainDisplay = case appMode st of
UrlSelect -> renderUrlList st
_ -> maybeSubdue $ renderCurrentChannelDisplay st hs
bottomBorder = case appMode st of
MessageSelect -> messageSelectBottomBar st
_ -> maybeSubdue $ hBox
[ showAttachmentCount
, hBorder
, showTypingUsers
, showBusy
]
showAttachmentCount =
let count = length $ listElements $ st^.csEditState.cedAttachmentList
in if count == 0
then emptyWidget
else hBox [ borderElem bsHorizontal
, withDefAttr clientMessageAttr $
txt $ "(" <> (T.pack $ show count) <> " attachment" <>
(if count == 1 then "" else "s") <> "; "
, withDefAttr clientEmphAttr $
txt $ ppBinding (getFirstDefaultBinding ShowAttachmentListEvent)
, txt " to manage)"
]
showTypingUsers =
let format = renderText' Nothing (myUsername st) hs
in case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of
[] -> emptyWidget
[uId] | Just un <- usernameForUserId uId st ->
format $ "[" <> userSigil <> un <> " is typing]"
[uId1, uId2] | Just un1 <- usernameForUserId uId1 st
, Just un2 <- usernameForUserId uId2 st ->
format $ "[" <> userSigil <> un1 <> " and " <> userSigil <> un2 <> " are typing]"
_ -> format "[several people are typing]"
showBusy = case st^.csWorkerIsBusy of
Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)
Just Nothing -> hLimit 2 hBorder <+> txt "*"
Nothing -> emptyWidget
maybeSubdue = if appMode st == ChannelSelect
then forceAttr ""
else id
replyArrow :: Widget a
replyArrow =
Widget Fixed Fixed $ do
ctx <- getContext
let bs = ctx^.ctxBorderStyleL
render $ str [' ', bsCornerTL bs, '▸']