matterhorn-30802.1.0: src/Draw/Main.hs
{-# LANGUAGE MultiWayIf #-}
module Draw.Main (drawMain) where
import Prelude ()
import Prelude.Compat
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center (hCenter)
import Brick.Widgets.Edit (editContentsL, renderEditor, getEditContents)
import Brick.Widgets.List (renderList)
import Control.Arrow ((>>>))
import Control.Monad (foldM)
import Control.Monad.Trans.Reader (withReaderT)
import Data.Time.Clock (UTCTime(..))
import Data.Time.Calendar (fromGregorian)
import Data.Time.Format ( formatTime
, defaultTimeLocale )
import Data.Time.LocalTime ( TimeZone, utcToLocalTime
, localTimeToUTC, localDay
, LocalTime(..), midnight )
import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.HashMap.Strict ( HashMap )
import Data.List (intersperse)
import qualified Data.Map.Strict as Map
import Data.Maybe (listToMaybe, maybeToList, catMaybes, isJust)
import Data.Monoid ((<>))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Zipper (cursorPosition, insertChar, getText, gotoEOL)
import Lens.Micro.Platform
import Network.Mattermost
import Network.Mattermost.Lenses
import qualified Graphics.Vty as Vty
import Markdown
import State
import State.Common
import Themes
import Types
import Types.Posts
import Types.Messages
import Draw.Util
renderChatMessage :: UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name
renderChatMessage uSet cSet renderTimeFunc msg =
let m = renderMessage msg True uSet cSet
msgAtch = if Seq.null (msg^.mAttachments)
then emptyWidget
else withDefAttr clientMessageAttr $ vBox
[ txt (" [attached: `" <> a^.attachmentName <> "`]")
| a <- F.toList (msg^.mAttachments)
]
msgReac = if Map.null (msg^.mReactions)
then emptyWidget
else let renderR e 1 = " [" <> e <> "]"
renderR e n
| n > 1 = " [" <> e <> " " <> T.pack (show n) <> "]"
| otherwise = ""
reacMsg = Map.foldMapWithKey renderR (msg^.mReactions)
in withDefAttr emojiAttr $ txt (" " <> reacMsg)
msgTxt =
case msg^.mUserName of
Just _
| msg^.mType == CP Join || msg^.mType == CP Leave ->
withDefAttr clientMessageAttr m
| otherwise -> m
Nothing ->
case msg^.mType of
C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m)
C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m)
C Error -> withDefAttr errorMessageAttr m
_ -> withDefAttr clientMessageAttr m
fullMsg = msgTxt <=> msgAtch <=> msgReac
maybeRenderTime w = renderTimeFunc (msg^.mDate) <+> txt " " <+> w
maybeRenderTimeWith f = case msg^.mType of
C DateTransition -> id
C NewMessagesTransition -> id
_ -> f
in maybeRenderTimeWith maybeRenderTime fullMsg
channelListWidth :: Int
channelListWidth = 20
renderChannelList :: ChatState -> Widget Name
renderChannelList st = hLimit channelListWidth $ maybeViewport $
vBox $ concat $ renderChannelGroup st <$> channelGroups
where
-- Only render the channel list in a viewport if we're not in
-- channel select mode, since we don't want or need the viewport
-- state to be affected by channel select input.
maybeViewport = if st^.csMode == ChannelSelect
then id
else viewport ChannelList Vertical
channelGroups = [ ( "Channels"
, getOrdinaryChannels st
, st^.csChannelSelectChannelMatches
)
, ( "Users"
, getDmChannels st
, st^.csChannelSelectUserMatches
)
]
renderChannelGroup :: ChatState
-> (T.Text, [ChannelListEntry], HM.HashMap T.Text ChannelSelectMatch)
-> [Widget Name]
renderChannelGroup st (groupName, entries, csMatches) =
let header label = hBorderWithLabel $ withDefAttr channelListHeaderAttr $ txt label
in header groupName : (renderChannelListEntry st csMatches <$> entries)
data ChannelListEntry =
ChannelListEntry { entryChannelName :: T.Text
, entrySigil :: T.Text
, entryLabel :: T.Text
, entryMakeWidget :: T.Text -> Widget Name
, entryHasUnread :: Bool
, entryIsRecent :: Bool
}
renderChannelListEntry :: ChatState
-> HM.HashMap T.Text ChannelSelectMatch
-> ChannelListEntry
-> Widget Name
renderChannelListEntry st csMatches entry =
decorate $ decorateRecent $ padRight Max $
entryMakeWidget entry $ entrySigil entry <> entryLabel entry
where
decorate = if | matches -> const $
let Just (ChannelSelectMatch preMatch inMatch postMatch) =
HM.lookup (entryLabel entry) csMatches
in (txt $ entrySigil entry)
<+> txt preMatch
<+> (forceAttr channelSelectMatchAttr $ txt inMatch)
<+> txt postMatch
| isChanSelect &&
(not $ T.null $ st^.csChannelSelectString) -> const emptyWidget
| current ->
if isChanSelect
then forceAttr currentChannelNameAttr
else visible . forceAttr currentChannelNameAttr
| entryHasUnread entry ->
forceAttr unreadChannelAttr
| otherwise -> id
decorateRecent = if entryIsRecent entry
then (<+> (withDefAttr recentMarkerAttr $ str "<"))
else id
matches = isChanSelect && (HM.member (entryLabel entry) csMatches) &&
(not $ T.null $ st^.csChannelSelectString)
isChanSelect = st^.csMode == ChannelSelect
current = entryChannelName entry == currentChannelName
currentChannelName = st^.csCurrentChannel.ccInfo.cdName
getOrdinaryChannels :: ChatState -> [ChannelListEntry]
getOrdinaryChannels st =
[ ChannelListEntry n sigil n txt unread recent
| n <- (st ^. csNames . cnChans)
, let Just chan = st ^. csNames . cnToChanId . at n
unread = hasUnread st chan
recent = Just chan == st^.csRecentChannel
sigil = case st ^. csLastChannelInput . at chan of
Nothing -> T.singleton normalChannelSigil
Just ("", _) -> T.singleton normalChannelSigil
_ -> "»"
]
getDmChannels :: ChatState -> [ChannelListEntry]
getDmChannels st =
[ ChannelListEntry cname sigil uname colorUsername' unread recent
| u <- sortedUserList st
, let colorUsername' =
if | u^.uiStatus == Offline ->
withDefAttr clientMessageAttr . txt
| otherwise ->
colorUsername
sigil =
case do { cId <- m_chanId; st^.csLastChannelInput.at cId } of
Nothing -> T.singleton $ userSigilFromInfo u
Just ("", _) -> T.singleton $ userSigilFromInfo u
_ -> "»"
uname = u^.uiName
cname = getDMChannelName (st^.csMe^.userIdL) (u^.uiId)
recent = maybe False ((== st^.csRecentChannel) . Just) m_chanId
m_chanId = st^.csNames.cnToChanId.at (u^.uiName)
unread = maybe False (hasUnread st) m_chanId
]
previewFromInput :: T.Text -> T.Text -> Maybe Message
previewFromInput _ s | s == T.singleton cursorSentinel = Nothing
previewFromInput uname s =
-- If it starts with a slash but not /me, this has no preview
-- representation
let isCommand = "/" `T.isPrefixOf` s
isEmote = "/me " `T.isPrefixOf` s
content = if isEmote
then T.stripStart $ T.drop 3 s
else s
msgTy = if isEmote then CP Emote else CP NormalPost
in if isCommand && not isEmote
then Nothing
else Just $ Message { _mText = getBlocks content
, _mUserName = Just uname
, _mDate = UTCTime (fromGregorian 1970 1 1) 0
-- The date is not used for preview
-- rendering, but we need to provide one.
-- Ideally we'd just today's date, but the
-- rendering function is pure so we can't.
, _mType = msgTy
, _mPending = False
, _mDeleted = False
, _mAttachments = mempty
, _mInReplyToMsg = NotAReply
, _mPostId = Nothing
, _mReactions = mempty
, _mOriginalPost = Nothing
}
renderUserCommandBox :: UserSet -> ChannelSet -> ChatState -> Widget Name
renderUserCommandBox uSet cSet st =
let prompt = txt $ case st^.csEditState.cedEditMode of
Replying _ _ -> "reply> "
Editing _ -> "edit> "
NewPost -> "> "
inputBox = renderEditor True (st^.csCmdLine)
curContents = getEditContents $ st^.csCmdLine
multilineContent = length curContents > 1
multilineHints =
(borderElem bsHorizontal) <+>
(str $ "[" <> (show $ (+1) $ fst $ cursorPosition $
st^.csCmdLine.editContentsL) <>
"/" <> (show $ length curContents) <> "]") <+>
(hBorderWithLabel $ withDefAttr clientEmphAttr $
(str "In multi-line mode. Press M-e to finish."))
replyDisplay = case st^.csEditState.cedEditMode of
Replying msg _ ->
let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply
in hBox [ replyArrow
, addEllipsis $ renderMessage msgWithoutParent True uSet cSet
]
_ -> emptyWidget
commandBox = case st^.csEditState.cedMultiline of
False ->
let linesStr = if numLines == 1
then "line"
else "lines"
numLines = length curContents
in vLimit 1 $
prompt <+> if multilineContent
then ((withDefAttr clientEmphAttr $
str $ "[" <> show numLines <> " " <> linesStr <>
"; Enter: send, M-e: edit, Backspace: cancel] ")) <+>
(txt $ head curContents) <+>
(showCursor MessageInput (Location (0,0)) $ str " ")
else inputBox
True -> vLimit 5 inputBox <=> multilineHints
in replyDisplay <=> commandBox
maxMessageHeight :: Int
maxMessageHeight = 200
renderSingleMessage :: ChatState -> UserSet -> ChannelSet -> Message -> Widget Name
renderSingleMessage st uSet cSet = renderChatMessage uSet cSet (withBrackets . renderTime st)
renderCurrentChannelDisplay :: UserSet -> ChannelSet -> ChatState -> Widget Name
renderCurrentChannelDisplay uSet cSet st = (header <+> conn) <=> messages
where
conn = case st^.csConnectionStatus of
Connected -> emptyWidget
Disconnected -> withDefAttr errorMessageAttr (str "[NOT CONNECTED]")
header = withDefAttr channelHeaderAttr $
padRight Max $
case T.null topicStr of
True -> case chnType of
Direct ->
case findUserByDMChannelName (st^.usrMap)
chnName
(st^.csMe^.userIdL) of
Nothing -> txt $ mkChannelName (chan^.ccInfo)
Just u -> colorUsername $ mkDMChannelName u
_ -> txt $ mkChannelName (chan^.ccInfo)
False -> renderText $
mkChannelName (chan^.ccInfo) <> " - " <> topicStr
messages = body <+> txt " "
body = chatText <=> case chan^.ccInfo.cdCurrentState of
ChanUnloaded -> withDefAttr clientMessageAttr $
txt "[Loading channel...]"
ChanLoadPending -> withDefAttr clientMessageAttr $
txt "[Loading channel...]"
ChanRefreshing -> withDefAttr clientMessageAttr $
txt "[Refreshing channel...]"
_ -> emptyWidget
chatText = case st^.csMode of
ChannelScroll ->
viewport (ChannelMessages cId) Vertical $
cached (ChannelMessages cId) $
vBox $ (withDefAttr loadMoreAttr $ hCenter $
str "<< Press C-b to load more messages >>") :
(F.toList $ renderSingleMessage st uSet cSet <$> channelMessages)
MessageSelect ->
renderMessagesWithSelect (st^.csMessageSelect) channelMessages
MessageSelectDeleteConfirm ->
renderMessagesWithSelect (st^.csMessageSelect) channelMessages
_ -> renderLastMessages $ reverseMessages channelMessages
renderMessagesWithSelect (MessageSelectState selPostId) 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)) = splitMessages selPostId msgs
in case s of
Nothing -> renderLastMessages before
Just m -> unsafeMessageSelectList before after m
unsafeMessageSelectList before after curMsg = Widget Greedy Greedy $ do
ctx <- getContext
-- Render the message associated with the current post ID.
curMsgResult <- withReaderT relaxHeight $ render $
forceAttr messageSelectAttr $
padRight Max $ renderSingleMessage st uSet cSet curMsg
let targetHeight = ctx^.availHeightL
upperHeight = targetHeight `div` 2
lowerHeight = targetHeight - upperHeight
lowerRender = render1HLimit Vty.vertJoin targetHeight
upperRender = render1HLimit (flip Vty.vertJoin) targetHeight
lowerHalf <- foldM lowerRender Vty.emptyImage after
upperHalf <- foldM upperRender Vty.emptyImage before
let curHeight = Vty.imageHeight $ curMsgResult^.imageL
uncropped = upperHalf Vty.<-> curMsgResult^.imageL Vty.<-> lowerHalf
img = if Vty.imageHeight lowerHalf < (lowerHeight - curHeight)
then Vty.cropTop targetHeight uncropped
else if Vty.imageHeight upperHalf < upperHeight
then Vty.cropBottom targetHeight uncropped
else Vty.cropTop upperHeight upperHalf Vty.<->
curMsgResult^.imageL Vty.<->
(if curHeight < lowerHeight
then Vty.cropBottom (lowerHeight - curHeight) lowerHalf
else Vty.cropBottom lowerHeight lowerHalf)
return $ emptyResult & imageL .~ img
channelMessages =
insertTransitions (getDateFormat st)
(st ^. timeZone)
(getNewMessageCutoff cId st)
(getMessageListing cId st)
renderLastMessages :: RetrogradeMessages -> Widget Name
renderLastMessages msgs =
Widget Greedy Greedy $ do
ctx <- getContext
let targetHeight = ctx^.availHeightL
renderBuild = render1HLimit (flip Vty.vertJoin) targetHeight
img <- foldM renderBuild Vty.emptyImage msgs
return $ emptyResult & imageL .~ (Vty.cropTop targetHeight img)
relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))
render1HLimit fjoin lim img msg = if Vty.imageHeight img >= lim
then return img
else fjoin img <$> render1 msg
render1 :: Message -> RenderM Name Vty.Image
render1 msg = case msg^.mDeleted of
True -> return Vty.emptyImage
False -> do
r <- withReaderT relaxHeight $
render $ padRight Max $
renderSingleMessage st uSet cSet msg
return $ r^.imageL
cId = st^.csCurrentChannelId
chan = st^.csCurrentChannel
chnName = chan^.ccInfo.cdName
chnType = chan^.ccInfo.cdType
topicStr = chan^.ccInfo.cdHeader
getMessageListing :: ChannelId -> ChatState -> Messages
getMessageListing cId st =
st ^. msgMap . ix cId . ccContents . cdMessages
insertTransitions :: Text -> TimeZone -> Maybe UTCTime -> Messages -> Messages
insertTransitions datefmt tz cutoff ms = foldr addMessage ms transitions
where transitions = newMessagesT <> dateT
newMessagesT = case cutoff of
Nothing -> []
Just t -> [newMessagesMsg $ justBefore t]
dateT = fmap dateMsg dateRange
dateRange = let dr = foldr checkDateChange [] ms
in if length dr > 1 then tail dr else []
checkDateChange m [] = [dayStart $ m^.mDate]
checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate)
then dl
else dayStart (m^.mDate) : dl
dayOf = localDay . utcToLocalTime tz
dayStart dt = localTimeToUTC tz $ LocalTime (dayOf dt) $ midnight
justBefore (UTCTime d t) = UTCTime d $ pred t
dateMsg d = Message (getBlocks (T.pack $ formatTime defaultTimeLocale
(T.unpack datefmt)
(utcToLocalTime tz d)))
Nothing d (C DateTransition) False False
Seq.empty NotAReply Nothing mempty Nothing
newMessagesMsg d = Message (getBlocks (T.pack "New Messages"))
Nothing d (C NewMessagesTransition)
False False Seq.empty NotAReply
Nothing mempty Nothing
findUserByDMChannelName :: HashMap UserId UserInfo
-> T.Text -- ^ the dm channel name
-> UserId -- ^ me
-> Maybe UserInfo -- ^ you
findUserByDMChannelName userMap dmchan me = listToMaybe
[ user
| u <- HM.keys userMap
, getDMChannelName me u == dmchan
, user <- maybeToList (HM.lookup u userMap)
]
renderChannelSelect :: ChatState -> Widget Name
renderChannelSelect st =
withDefAttr channelSelectPromptAttr $
(txt "Switch to channel: ") <+>
(showCursor ChannelSelectString (Location (T.length $ st^.csChannelSelectString, 0)) $
txt $
(if T.null $ st^.csChannelSelectString
then " "
else st^.csChannelSelectString))
drawMain :: ChatState -> [Widget Name]
drawMain st = [mainInterface st]
messageSelectBottomBar :: ChatState -> Widget Name
messageSelectBottomBar st =
let optionStr = if null usableOptions
then "(no actions available for this message)"
else T.intercalate " " usableOptions
usableOptions = catMaybes $ mkOption <$> options
mkOption (f, k, desc) = if f postMsg
then Just $ k <> ":" <> 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))
options = [ (isReplyable, "r", "reply")
, (\m -> isMine st m && isEditable m, "e", "edit")
, (\m -> isMine st m && isDeletable m, "d", "delete")
, (const hasURLs, "o", openUrlsMsg)
, (const hasVerb, "y", "yank")
]
Just postMsg = getSelectedMessage st
in hBox [ borderElem bsHorizontal
, txt "["
, withDefAttr messageSelectStatusAttr $
txt $ "Message select: " <> optionStr
, txt "]"
, hBorder
]
completionAlternatives :: ChatState -> Widget Name
completionAlternatives st =
let alternatives = intersperse (txt " ") $ mkAlternative <$> st^.csEditState.cedCompletionAlternatives
mkAlternative val = let format = if val == st^.csEditState.cedCurrentAlternative
then visible . withDefAttr completionAlternativeCurrentAttr
else id
in format $ txt val
in hBox [ borderElem bsHorizontal
, txt "["
, withDefAttr completionAlternativeListAttr $
vLimit 1 $ viewport CompletionAlternatives Horizontal $ hBox alternatives
, txt "]"
, borderElem bsHorizontal
]
previewMaxHeight :: Int
previewMaxHeight = 5
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 :: UserSet -> ChannelSet -> ChatState -> Widget Name
inputPreview uSet cSet st | not $ st^.csShowMessagePreview = emptyWidget
| otherwise = thePreview
where
uname = st^.csMe.userUsernameL
-- 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^.csCmdLine.editContentsL
curStr = T.intercalate "\n" curContents
previewMsg = previewFromInput uname curStr
thePreview = let noPreview = str "(No preview)"
msgPreview = case previewMsg of
Nothing -> noPreview
Just pm -> if T.null curStr
then noPreview
else renderMessage pm True uSet cSet
in (maybePreviewViewport msgPreview) <=>
hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")
userInputArea :: UserSet -> ChannelSet -> ChatState -> Widget Name
userInputArea uSet cSet st =
case st^.csMode of
ChannelSelect -> renderChannelSelect st
UrlSelect -> hCenter $ hBox [ txt "Press "
, withDefAttr clientEmphAttr $ txt "Enter"
, txt " to open the selected URL or "
, withDefAttr clientEmphAttr $ txt "Escape"
, txt " to cancel."
]
ChannelScroll -> hCenter $ hBox [ txt "Press "
, withDefAttr clientEmphAttr $ txt "Escape"
, txt " to stop scrolling and resume chatting."
]
MessageSelectDeleteConfirm -> renderDeleteConfirm
_ -> renderUserCommandBox uSet cSet st
renderDeleteConfirm :: Widget Name
renderDeleteConfirm =
hCenter $ txt "Are you sure you want to delete the selected message? (y/n)"
mainInterface :: ChatState -> Widget Name
mainInterface st =
(renderChannelList st <+> vBorder <+> mainDisplay)
<=> bottomBorder
<=> inputPreview uSet cSet st
<=> userInputArea uSet cSet st
where
mainDisplay = case st^.csMode of
UrlSelect -> renderUrlList st
_ -> maybeSubdue $ renderCurrentChannelDisplay uSet cSet st
uSet = Set.fromList (map _uiName (HM.elems (st^.usrMap)))
cSet = Set.fromList (_cdName <$> _ccInfo <$> (HM.elems $ st^.msgMap))
bottomBorder = case st^.csMode of
MessageSelect -> messageSelectBottomBar st
_ -> case st^.csCurrentCompletion of
Just _ | length (st^.csEditState.cedCompletionAlternatives) > 1 -> completionAlternatives st
_ -> maybeSubdue $ hLimit channelListWidth hBorder <+> borderElem bsIntersectB <+> hBorder
maybeSubdue = if st^.csMode == ChannelSelect
then forceAttr ""
else id
renderUrlList :: ChatState -> Widget Name
renderUrlList st =
header <=> urlDisplay
where
header = withDefAttr channelHeaderAttr $ vLimit 1 $
(txt $ "URLs: " <> (st^.csCurrentChannel.ccInfo.cdName)) <+>
fill ' '
urlDisplay = if F.length urls == 0
then str "No URLs found in this channel."
else renderList renderItem True urls
urls = st^.csUrlList
renderItem sel link =
let time = link^.linkTime
in attr sel $ vLimit 2 $
(vLimit 1 $
hBox [ colorUsername (link^.linkUser)
, if link^.linkName == link^.linkURL
then emptyWidget
else (txt ": " <+> (renderText $ link^.linkName))
, fill ' '
, renderDate st time
, str " "
, renderTime st time
] ) <=>
(vLimit 1 (renderText $ link^.linkURL))
attr True = forceAttr "urlListSelectedAttr"
attr False = id