{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Matterhorn.Draw.Messages
( MessageData(..)
, renderMessage
, printableNameForUserRef
, renderSingleMessage
, unsafeRenderMessageSelection
, renderLastMessages
, addEllipsis
, mkClickableInline
)
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 Data.Maybe ( fromJust )
import qualified Graphics.Vty as V
import Lens.Micro.Platform ( (.~), to )
import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )
import Network.Mattermost.Types ( ServerTime(..), UserId, userUsername, userId, postId )
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
data MessageData =
MessageData { MessageData -> Maybe ServerTime
mdEditThreshold :: Maybe ServerTime
, MessageData -> Bool
mdShowOlderEdits :: Bool
, MessageData -> Bool
mdShowReactions :: Bool
, MessageData -> Message
mdMessage :: Message
, MessageData -> Maybe Text
mdUserName :: Maybe Text
, MessageData -> Maybe Message
mdParentMessage :: Maybe Message
, MessageData -> Maybe Text
mdParentUserName :: Maybe Text
, MessageData -> ThreadState
mdThreadState :: ThreadState
, MessageData -> Bool
mdRenderReplyParent :: Bool
, MessageData -> Bool
mdRenderReplyIndent :: Bool
, MessageData -> HighlightSet
mdHighlightSet :: HighlightSet
, MessageData -> Bool
mdIndentBlocks :: Bool
, MessageData -> Maybe Int
mdTruncateVerbatimBlocks :: Maybe Int
, MessageData -> Maybe Int
mdMessageWidthLimit :: Maybe Int
, MessageData -> Text
mdMyUsername :: Text
, MessageData -> UserId
mdMyUserId :: UserId
, MessageData -> Bool
mdWrapNonhighlightedCodeBlocks :: Bool
, MessageData -> Name
mdClickableNameTag :: Name
}
maxMessageHeight :: Int
maxMessageHeight :: Int
maxMessageHeight = Int
200
botUserLabel :: T.Text
botUserLabel :: Text
botUserLabel = Text
"[BOT]"
pinIndicator :: T.Text
pinIndicator :: Text
pinIndicator = Text
"[PIN]"
printableNameForUserRef :: ChatState -> UserRef -> Maybe Text
printableNameForUserRef :: ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st UserRef
uref =
case UserRef
uref of
UserRef
NoUser -> forall a. Maybe a
Nothing
UserOverride Bool
_ Text
t -> forall a. a -> Maybe a
Just Text
t
UserI Bool
_ UserId
uId -> UserId -> ChatState -> Maybe Text
displayNameForUserId UserId
uId ChatState
st
renderSingleMessage :: ChatState
-> HighlightSet
-> Bool
-> Maybe ServerTime
-> Message
-> ThreadState
-> Name
-> Widget Name
renderSingleMessage :: ChatState
-> HighlightSet
-> Bool
-> Maybe ServerTime
-> Message
-> ThreadState
-> Name
-> Widget Name
renderSingleMessage ChatState
st HighlightSet
hs Bool
renderReplyIndent Maybe ServerTime
ind Message
m ThreadState
threadState Name
tag =
ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> Name
-> (ServerTime -> Widget Name)
-> Bool
-> Message
-> Widget Name
renderChatMessage ChatState
st HighlightSet
hs Maybe ServerTime
ind ThreadState
threadState Name
tag
(forall a. Widget a -> Widget a
withBrackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatState -> UTCTime -> Widget Name
renderTime ChatState
st forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerTime -> UTCTime
withServerTime)
Bool
renderReplyIndent Message
m
renderChatMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> Name
-> (ServerTime -> Widget Name)
-> Bool
-> Message
-> Widget Name
renderChatMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> Name
-> (ServerTime -> Widget Name)
-> Bool
-> Message
-> Widget Name
renderChatMessage ChatState
st HighlightSet
hs Maybe ServerTime
ind ThreadState
threadState Name
clickableNameTag ServerTime -> Widget Name
renderTimeFunc Bool
renderReplyIndent Message
msg =
let showOlderEdits :: Bool
showOlderEdits = Config -> Bool
configShowOlderEdits Config
config
showTimestamp :: Bool
showTimestamp = Config -> Bool
configShowMessageTimestamps Config
config
config :: Config
config = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfiguration
parent :: Maybe Message
parent = case Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message ReplyState
mInReplyToMsg of
ReplyState
NotAReply -> forall a. Maybe a
Nothing
InReplyTo PostId
pId -> ChatState -> PostId -> Maybe Message
getMessageForPostId ChatState
st PostId
pId
m :: Widget Name
m = MessageData -> Widget Name
renderMessage MessageData
{ mdMessage :: Message
mdMessage = Message
msg
, mdUserName :: Maybe Text
mdUserName = Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message UserRef
mUserforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st)
, mdParentMessage :: Maybe Message
mdParentMessage = Maybe Message
parent
, mdParentUserName :: Maybe Text
mdParentUserName = Maybe Message
parent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall s a. s -> Getting a s a -> a
^.Lens' Message UserRef
mUserforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st))
, mdEditThreshold :: Maybe ServerTime
mdEditThreshold = Maybe ServerTime
ind
, mdHighlightSet :: HighlightSet
mdHighlightSet = HighlightSet
hs
, mdShowOlderEdits :: Bool
mdShowOlderEdits = Bool
showOlderEdits
, mdRenderReplyParent :: Bool
mdRenderReplyParent = Bool
True
, mdRenderReplyIndent :: Bool
mdRenderReplyIndent = Bool
renderReplyIndent
, mdIndentBlocks :: Bool
mdIndentBlocks = Bool
True
, mdThreadState :: ThreadState
mdThreadState = ThreadState
threadState
, mdShowReactions :: Bool
mdShowReactions = Bool
True
, mdMessageWidthLimit :: Maybe Int
mdMessageWidthLimit = forall a. Maybe a
Nothing
, mdMyUsername :: Text
mdMyUsername = User -> Text
userUsername forall a b. (a -> b) -> a -> b
$ ChatState -> User
myUser ChatState
st
, mdMyUserId :: UserId
mdMyUserId = User -> UserId
userId forall a b. (a -> b) -> a -> b
$ ChatState -> User
myUser ChatState
st
, mdWrapNonhighlightedCodeBlocks :: Bool
mdWrapNonhighlightedCodeBlocks = Bool
True
, mdTruncateVerbatimBlocks :: Maybe Int
mdTruncateVerbatimBlocks = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (Maybe Int)
csVerbatimTruncateSetting
, mdClickableNameTag :: Name
mdClickableNameTag = Name
clickableNameTag
}
fullMsg :: Widget Name
fullMsg =
case Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message UserRef
mUser of
UserRef
NoUser
| Message -> Bool
isGap Message
msg -> forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
gapMessageAttr Widget Name
m
| Bool
otherwise ->
case Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message MessageType
mType of
C ClientMessageType
DateTransition ->
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
dateTransitionAttr (forall a. Widget a -> Widget a
hBorderWithLabel Widget Name
m)
C ClientMessageType
NewMessagesTransition ->
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
newMessageTransitionAttr (forall a. Widget a -> Widget a
hBorderWithLabel Widget Name
m)
C ClientMessageType
Error ->
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
errorMessageAttr Widget Name
m
MessageType
_ ->
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr Widget Name
m
UserRef
_ | Message -> Bool
isJoinLeave Message
msg -> forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr Widget Name
m
| Bool
otherwise -> Widget Name
m
maybeRenderTime :: Widget Name -> Widget Name
maybeRenderTime Widget Name
w =
if Bool
showTimestamp
then let maybePadTime :: Widget n -> Widget n
maybePadTime = if ThreadState
threadState forall a. Eq a => a -> a -> Bool
== ThreadState
InThreadShowParent
then (forall n. Text -> Widget n
txt Text
" " forall n. Widget n -> Widget n -> Widget n
<=>) else forall a. a -> a
id
in forall n. [Widget n] -> Widget n
hBox [forall a. Widget a -> Widget a
maybePadTime forall a b. (a -> b) -> a -> b
$ ServerTime -> Widget Name
renderTimeFunc (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message ServerTime
mDate), forall n. Text -> Widget n
txt Text
" ", Widget Name
w]
else Widget Name
w
maybeRenderTimeWith :: (a -> a) -> a -> a
maybeRenderTimeWith a -> a
f = if Message -> Bool
isTransition Message
msg then forall a. a -> a
id else a -> a
f
in forall {a}. (a -> a) -> a -> a
maybeRenderTimeWith Widget Name -> Widget Name
maybeRenderTime Widget Name
fullMsg
unsafeRenderMessageSelection :: (SeqDirection dir1, SeqDirection dir2)
=> ( (Message, ThreadState)
, ( DirectionalSeq dir1 (Message, ThreadState)
, DirectionalSeq dir2 (Message, ThreadState)
)
)
-> (Message -> ThreadState -> Name -> Widget Name)
-> Name
-> Widget Name
unsafeRenderMessageSelection :: forall dir1 dir2.
(SeqDirection dir1, SeqDirection dir2) =>
((Message, ThreadState),
(DirectionalSeq dir1 (Message, ThreadState),
DirectionalSeq dir2 (Message, ThreadState)))
-> (Message -> ThreadState -> Name -> Widget Name)
-> Name
-> Widget Name
unsafeRenderMessageSelection ((Message
curMsg, ThreadState
curThreadState), (DirectionalSeq dir1 (Message, ThreadState)
before, DirectionalSeq dir2 (Message, ThreadState)
after)) Message -> ThreadState -> Name -> Widget Name
doMsgRender Name
tag =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy forall a b. (a -> b) -> a -> b
$ do
Context Name
ctx <- forall n. RenderM n (Context n)
getContext
Result Name
curMsgResult <- forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall n. Context n -> Context n
relaxHeight forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$
forall n. AttrName -> Widget n -> Widget n
forceAttr AttrName
messageSelectAttr forall a b. (a -> b) -> a -> b
$
forall n. Padding -> Widget n -> Widget n
padRight Padding
Max forall a b. (a -> b) -> a -> b
$ Message -> ThreadState -> Name -> Widget Name
doMsgRender Message
curMsg ThreadState
curThreadState Name
tag
let targetHeight :: Int
targetHeight = Context Name
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availHeightL
upperHeight :: Int
upperHeight = Int
targetHeight forall a. Integral a => a -> a -> a
`div` Int
2
lowerHeight :: Int
lowerHeight = Int
targetHeight forall a. Num a => a -> a -> a
- Int
upperHeight
[Result Name]
lowerHalfResults <- forall dir.
SeqDirection dir =>
Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir (Message, ThreadState)
-> RenderM Name [Result Name]
renderMessageSeq Int
targetHeight ((Message -> ThreadState -> Name -> Widget Name)
-> Message -> ThreadState -> Name -> Widget Name
render1 Message -> ThreadState -> Name -> Widget Name
doMsgRender) forall n. Int -> Widget n -> Widget n
vLimit Name
tag DirectionalSeq dir2 (Message, ThreadState)
after
[Result Name]
upperHalfResults <- forall dir.
SeqDirection dir =>
Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir (Message, ThreadState)
-> RenderM Name [Result Name]
renderMessageSeq Int
targetHeight ((Message -> ThreadState -> Name -> Widget Name)
-> Message -> ThreadState -> Name -> Widget Name
render1 Message -> ThreadState -> Name -> Widget Name
doMsgRender) forall n. Int -> Widget n -> Widget n
cropTopTo Name
tag DirectionalSeq dir1 (Message, ThreadState)
before
let upperHalfResultsHeight :: Int
upperHalfResultsHeight = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ (Image -> Int
V.imageHeight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Result n -> Image
image) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Result Name]
upperHalfResults
lowerHalfResultsHeight :: Int
lowerHalfResultsHeight = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ (Image -> Int
V.imageHeight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Result n -> Image
image) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Result Name]
lowerHalfResults
curHeight :: Int
curHeight = Image -> Int
V.imageHeight forall a b. (a -> b) -> a -> b
$ Result Name
curMsgResultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL
uncropped :: Widget Name
uncropped = forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Result n -> Widget n
resultToWidget forall a b. (a -> b) -> a -> b
$
(forall a. [a] -> [a]
reverse [Result Name]
upperHalfResults) forall a. Semigroup a => a -> a -> a
<> (Result Name
curMsgResult forall a. a -> [a] -> [a]
: [Result Name]
lowerHalfResults)
cropTop :: Int -> Widget n -> Widget n
cropTop Int
h Widget n
w = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Result n
result <- forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall n. Context n -> Context n
relaxHeight forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> RenderM n (Result n)
render Widget n
w
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
cropTopTo Int
h forall a b. (a -> b) -> a -> b
$ forall n. Result n -> Widget n
resultToWidget Result n
result
cropBottom :: Int -> Widget n -> Widget n
cropBottom Int
h Widget n
w = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Result n
result <- forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall n. Context n -> Context n
relaxHeight forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> RenderM n (Result n)
render Widget n
w
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
cropBottomTo Int
h forall a b. (a -> b) -> a -> b
$ forall n. Result n -> Widget n
resultToWidget Result n
result
lowerHalf :: Widget Name
lowerHalf = forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Result n -> Widget n
resultToWidget [Result Name]
lowerHalfResults
upperHalf :: Widget Name
upperHalf = forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Result n -> Widget n
resultToWidget forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Result Name]
upperHalfResults
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ if | Int
lowerHalfResultsHeight forall a. Ord a => a -> a -> Bool
< (Int
lowerHeight forall a. Num a => a -> a -> a
- Int
curHeight) ->
forall n. Int -> Widget n -> Widget n
cropTop Int
targetHeight Widget Name
uncropped
| Int
upperHalfResultsHeight forall a. Ord a => a -> a -> Bool
< Int
upperHeight ->
forall n. Int -> Widget n -> Widget n
vLimit Int
targetHeight Widget Name
uncropped
| Bool
otherwise ->
forall n. Int -> Widget n -> Widget n
cropTop Int
upperHeight Widget Name
upperHalf forall n. Widget n -> Widget n -> Widget n
<=> (forall n. Result n -> Widget n
resultToWidget Result Name
curMsgResult) forall n. Widget n -> Widget n -> Widget n
<=>
(if Int
curHeight forall a. Ord a => a -> a -> Bool
< Int
lowerHeight
then forall n. Int -> Widget n -> Widget n
cropBottom (Int
lowerHeight forall a. Num a => a -> a -> a
- Int
curHeight) Widget Name
lowerHalf
else forall n. Int -> Widget n -> Widget n
cropBottom Int
lowerHeight Widget Name
lowerHalf)
renderMessageSeq :: (SeqDirection dir)
=> Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir (Message, ThreadState)
-> RenderM Name [Result Name]
renderMessageSeq :: forall dir.
SeqDirection dir =>
Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir (Message, ThreadState)
-> RenderM Name [Result Name]
renderMessageSeq Int
remainingHeight Message -> ThreadState -> Name -> Widget Name
renderFunc Int -> Widget Name -> Widget Name
limitFunc Name
tag DirectionalSeq dir (Message, ThreadState)
ms
| forall seq a. DirectionalSeq seq a -> Int
messagesLength DirectionalSeq dir (Message, ThreadState)
ms forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = do
let (Message
m, ThreadState
threadState) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall seq a. SeqDirection seq => DirectionalSeq seq a -> Maybe a
messagesHead DirectionalSeq dir (Message, ThreadState)
ms
maybeCache :: Widget Name -> Widget Name
maybeCache = case Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId of
Maybe MessageId
Nothing -> forall a. a -> a
id
Just MessageId
i -> forall n. Ord n => n -> Widget n -> Widget n
cached (MessageId -> Name
RenderedMessage MessageId
i)
Result Name
result <- forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
limitFunc Int
remainingHeight forall a b. (a -> b) -> a -> b
$ Widget Name -> Widget Name
maybeCache forall a b. (a -> b) -> a -> b
$ Message -> ThreadState -> Name -> Widget Name
renderFunc Message
m ThreadState
threadState Name
tag
[Result Name]
rest <- forall dir.
SeqDirection dir =>
Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir (Message, ThreadState)
-> RenderM Name [Result Name]
renderMessageSeq (Int
remainingHeight forall a. Num a => a -> a -> a
- (Image -> Int
V.imageHeight forall a b. (a -> b) -> a -> b
$ Result Name
resultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL)) Message -> ThreadState -> Name -> Widget Name
renderFunc Int -> Widget Name -> Widget Name
limitFunc Name
tag (forall seq a.
SeqDirection seq =>
Int -> DirectionalSeq seq a -> DirectionalSeq seq a
messagesDrop Int
1 DirectionalSeq dir (Message, ThreadState)
ms)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result Name
result forall a. a -> [a] -> [a]
: [Result Name]
rest
renderLastMessages :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> Bool
-> Name
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> Bool
-> Name
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages ChatState
st HighlightSet
hs Maybe ServerTime
editCutoff Bool
renderReplyIndent Name
tag DirectionalSeq Retrograde (Message, ThreadState)
msgs =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy forall a b. (a -> b) -> a -> b
$ do
Context Name
ctx <- forall n. RenderM n (Context n)
getContext
let targetHeight :: Int
targetHeight = Context Name
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availHeightL
doMsgRender :: Message -> ThreadState -> Name -> Widget Name
doMsgRender = ChatState
-> HighlightSet
-> Bool
-> Maybe ServerTime
-> Message
-> ThreadState
-> Name
-> Widget Name
renderSingleMessage ChatState
st HighlightSet
hs Bool
renderReplyIndent Maybe ServerTime
editCutoff
newMessagesTransitions :: DirectionalSeq Retrograde (Message, ThreadState)
newMessagesTransitions = forall seq a.
SeqDirection seq =>
(a -> Bool) -> DirectionalSeq seq a -> DirectionalSeq seq a
filterMessages (Message -> Bool
isNewMessagesTransition forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) DirectionalSeq Retrograde (Message, ThreadState)
msgs
newMessageTransition :: Maybe Message
newMessageTransition = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList DirectionalSeq Retrograde (Message, ThreadState)
newMessagesTransitions)
isBelow :: Message -> Message -> Bool
isBelow Message
m Message
transition = Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message ServerTime
mDate forall a. Ord a => a -> a -> Bool
> Message
transitionforall s a. s -> Getting a s a -> a
^.Lens' Message ServerTime
mDate
go :: Int -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name [Result Name]
go :: Int
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name [Result Name]
go Int
_ DirectionalSeq Retrograde (Message, ThreadState)
ms | forall seq a. DirectionalSeq seq a -> Int
messagesLength DirectionalSeq Retrograde (Message, ThreadState)
ms forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
go Int
remainingHeight DirectionalSeq Retrograde (Message, ThreadState)
ms = do
let (Message
m, ThreadState
threadState) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall seq a. SeqDirection seq => DirectionalSeq seq a -> Maybe a
messagesHead DirectionalSeq Retrograde (Message, ThreadState)
ms
newMessagesAbove :: Bool
newMessagesAbove = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Message -> Message -> Bool
isBelow Message
m) Maybe Message
newMessageTransition
Result Name
result <- forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ (Message -> ThreadState -> Name -> Widget Name)
-> Message -> ThreadState -> Name -> Widget Name
render1 Message -> ThreadState -> Name -> Widget Name
doMsgRender Message
m ThreadState
threadState Name
tag
Result Name
croppedResult <- forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
cropTopTo Int
remainingHeight forall a b. (a -> b) -> a -> b
$ forall n. Result n -> Widget n
resultToWidget Result Name
result
if Image -> Int
V.imageHeight (Result Name
resultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL) forall a. Ord a => a -> a -> Bool
>= Int
remainingHeight
then do
Result Name
single <- if Bool
newMessagesAbove
then do
Result Name
result' <- forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$
forall n. [Widget n] -> Widget n
vBox [ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
newMessageTransitionAttr forall a b. (a -> b) -> a -> b
$ forall a. Widget a -> Widget a
hBorderWithLabel (forall n. Text -> Widget n
txt Text
"New Messages ↑")
, forall n. Int -> Widget n -> Widget n
cropTopBy Int
1 forall a b. (a -> b) -> a -> b
$ forall n. Result n -> Widget n
resultToWidget Result Name
croppedResult
]
forall (m :: * -> *) a. Monad m => a -> m a
return Result Name
result'
else do
forall (m :: * -> *) a. Monad m => a -> m a
return Result Name
croppedResult
forall (m :: * -> *) a. Monad m => a -> m a
return [Result Name
single]
else do
let unusedHeight :: Int
unusedHeight = Int
remainingHeight forall a. Num a => a -> a -> a
- Image -> Int
V.imageHeight (Result Name
resultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL)
[Result Name]
rest <- Int
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name [Result Name]
go Int
unusedHeight forall a b. (a -> b) -> a -> b
$ forall seq a.
SeqDirection seq =>
Int -> DirectionalSeq seq a -> DirectionalSeq seq a
messagesDrop Int
1 DirectionalSeq Retrograde (Message, ThreadState)
ms
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result Name
result forall a. a -> [a] -> [a]
: [Result Name]
rest
[Result Name]
results <- Int
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name [Result Name]
go Int
targetHeight DirectionalSeq Retrograde (Message, ThreadState)
msgs
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall n. Result n -> Widget n
resultToWidget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
reverse [Result Name]
results
relaxHeight :: Context n -> Context n
relaxHeight :: forall n. Context n -> Context n
relaxHeight Context n
c = Context n
c forall a b. a -> (a -> b) -> b
& forall n. Lens' (Context n) Int
availHeightL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a. Ord a => a -> a -> a
max Int
maxMessageHeight (Context n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availHeightL))
render1 :: (Message -> ThreadState -> Name -> Widget Name)
-> Message
-> ThreadState
-> Name
-> Widget Name
render1 :: (Message -> ThreadState -> Name -> Widget Name)
-> Message -> ThreadState -> Name -> Widget Name
render1 Message -> ThreadState -> Name -> Widget Name
doMsgRender Message
msg ThreadState
threadState Name
tag = case Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mDeleted of
Bool
True -> forall n. Widget n
emptyWidget
Bool
False ->
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed forall a b. (a -> b) -> a -> b
$ do
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall n. Context n -> Context n
relaxHeight forall a b. (a -> b) -> a -> b
$
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Padding -> Widget n -> Widget n
padRight Padding
Max forall a b. (a -> b) -> a -> b
$
Message -> ThreadState -> Name -> Widget Name
doMsgRender Message
msg ThreadState
threadState Name
tag
renderMessage :: MessageData -> Widget Name
renderMessage :: MessageData -> Widget Name
renderMessage md :: MessageData
md@MessageData { mdMessage :: MessageData -> Message
mdMessage = Message
msg, Bool
Maybe Int
Maybe Text
Maybe ServerTime
Maybe Message
Text
UserId
Name
ThreadState
HighlightSet
mdClickableNameTag :: Name
mdWrapNonhighlightedCodeBlocks :: Bool
mdMyUserId :: UserId
mdMyUsername :: Text
mdMessageWidthLimit :: Maybe Int
mdTruncateVerbatimBlocks :: Maybe Int
mdIndentBlocks :: Bool
mdHighlightSet :: HighlightSet
mdRenderReplyIndent :: Bool
mdRenderReplyParent :: Bool
mdThreadState :: ThreadState
mdParentUserName :: Maybe Text
mdParentMessage :: Maybe Message
mdUserName :: Maybe Text
mdShowReactions :: Bool
mdShowOlderEdits :: Bool
mdEditThreshold :: Maybe ServerTime
mdClickableNameTag :: MessageData -> Name
mdWrapNonhighlightedCodeBlocks :: MessageData -> Bool
mdMyUserId :: MessageData -> UserId
mdMyUsername :: MessageData -> Text
mdMessageWidthLimit :: MessageData -> Maybe Int
mdTruncateVerbatimBlocks :: MessageData -> Maybe Int
mdIndentBlocks :: MessageData -> Bool
mdHighlightSet :: MessageData -> HighlightSet
mdRenderReplyIndent :: MessageData -> Bool
mdRenderReplyParent :: MessageData -> Bool
mdThreadState :: MessageData -> ThreadState
mdParentUserName :: MessageData -> Maybe Text
mdParentMessage :: MessageData -> Maybe Message
mdUserName :: MessageData -> Maybe Text
mdShowReactions :: MessageData -> Bool
mdShowOlderEdits :: MessageData -> Bool
mdEditThreshold :: MessageData -> Maybe ServerTime
.. } =
let msgUsr :: Maybe Text
msgUsr = case Maybe Text
mdUserName of
Just Text
u -> if MessageType -> Bool
omittedUsernameType (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message MessageType
mType)
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just Text
u
Maybe Text
Nothing -> forall a. Maybe a
Nothing
botAuthorElem :: Widget n
botAuthorElem = if Message -> Bool
isBotMessage Message
msg
then forall n. Text -> Widget n
txt Text
botUserLabel
else forall n. Widget n
emptyWidget
mId :: Maybe MessageId
mId = Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId
clickableAuthor :: Text -> Widget Name -> Widget Name
clickableAuthor Text
un = case Maybe MessageId
mId of
Maybe MessageId
Nothing -> forall a. a -> a
id
Just MessageId
i -> forall n. Ord n => n -> Widget n -> Widget n
clickable (Maybe MessageId -> Name -> Int -> Text -> Name
ClickableUsername (forall a. a -> Maybe a
Just MessageId
i) Name
mdClickableNameTag (-Int
1) Text
un)
nameElems :: [Widget Name]
nameElems = case Maybe Text
msgUsr of
Just Text
un
| Message -> Bool
isEmote Message
msg ->
[ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
pinnedMessageIndicatorAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ if Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mPinned then Text
pinIndicator else Text
""
, forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ (if Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mFlagged then Text
"[!] " else Text
"") forall a. Semigroup a => a -> a -> a
<> Text
"*"
, Text -> Widget Name -> Widget Name
clickableAuthor Text
un forall a b. (a -> b) -> a -> b
$ forall a. Text -> Text -> Text -> Widget a
colorUsername Text
mdMyUsername Text
un Text
un
, forall n. Widget n
botAuthorElem
, forall n. Text -> Widget n
txt Text
" "
]
| Bool
otherwise ->
[ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
pinnedMessageIndicatorAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ if Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mPinned then Text
pinIndicator forall a. Semigroup a => a -> a -> a
<> Text
" " else Text
""
, Text -> Widget Name -> Widget Name
clickableAuthor Text
un forall a b. (a -> b) -> a -> b
$ forall a. Text -> Text -> Text -> Widget a
colorUsername Text
mdMyUsername Text
un Text
un
, forall n. Widget n
botAuthorElem
, forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ (if Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mFlagged then Text
"[!]" else Text
"") forall a. Semigroup a => a -> a -> a
<> Text
": "
]
Maybe Text
Nothing -> []
maybeAugment :: Blocks -> Blocks
maybeAugment Blocks
bs = case Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe Post)
mOriginalPost of
Maybe Post
Nothing -> Blocks
bs
Just Post
p ->
if Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ServerTime
postEditAtL forall a. Ord a => a -> a -> Bool
> Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ServerTime
postCreateAtL
then case Maybe ServerTime
mdEditThreshold of
Just ServerTime
cutoff | Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ServerTime
postEditAtL forall a. Ord a => a -> a -> Bool
>= ServerTime
cutoff ->
Inline -> Blocks -> Blocks
addEditSentinel (Bool -> Inline
EEditSentinel Bool
True) Blocks
bs
Maybe ServerTime
_ -> if Bool
mdShowOlderEdits
then Inline -> Blocks -> Blocks
addEditSentinel (Bool -> Inline
EEditSentinel Bool
False) Blocks
bs
else Blocks
bs
else Blocks
bs
augmentedText :: Seq Block
augmentedText = Blocks -> Seq Block
unBlocks forall a b. (a -> b) -> a -> b
$ Blocks -> Blocks
maybeAugment forall a b. (a -> b) -> a -> b
$ Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message Blocks
mText
msgWidget :: Widget Name
msgWidget =
forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ (HighlightSet
-> Maybe Int
-> [Widget Name]
-> Seq Block
-> ViewL Block
-> Widget Name
renderBlocks HighlightSet
mdHighlightSet Maybe Int
mdMessageWidthLimit [Widget Name]
nameElems Seq Block
augmentedText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Seq a -> ViewL a
viewl) Seq Block
augmentedText forall a. a -> [a] -> [a]
:
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Widget Name)
msgAtch, MessageData -> Maybe (Widget Name)
messageReactions MessageData
md]
replyIndent :: Widget Name
replyIndent = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Context Name
ctx <- forall n. RenderM n (Context n)
getContext
Widget Name
w <- case Bool
mdRenderReplyIndent of
Bool
True -> do
Result Name
w <- forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
hLimit (Context Name
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availWidthL forall a. Num a => a -> a -> a
- Int
2) Widget Name
msgWidget
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
vLimit (Image -> Int
V.imageHeight forall a b. (a -> b) -> a -> b
$ Result Name
wforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL) forall a b. (a -> b) -> a -> b
$
forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) forall n. Widget n
vBorder forall n. Widget n -> Widget n -> Widget n
<+> forall n. Result n -> Widget n
resultToWidget Result Name
w
Bool
False ->
forall (m :: * -> *) a. Monad m => a -> m a
return Widget Name
msgWidget
forall n. Widget n -> RenderM n (Result n)
render Widget Name
w
msgAtch :: Maybe (Widget Name)
msgAtch = if forall a. Seq a -> Bool
S.null (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Seq Attachment)
mAttachments)
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
vBox
[ forall n. Padding -> Widget n -> Widget n
padLeft (Int -> Padding
Pad Int
2) forall a b. (a -> b) -> a -> b
$ forall n. Ord n => n -> Widget n -> Widget n
clickable (Name -> FileId -> Name
ClickableAttachmentInMessage Name
mdClickableNameTag (Attachment
aforall s a. s -> Getting a s a -> a
^.Lens' Attachment FileId
attachmentFileId)) forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt (Text
"[attached: `" forall a. Semigroup a => a -> a -> a
<> Attachment
aforall s a. s -> Getting a s a -> a
^.Lens' Attachment Text
attachmentName forall a. Semigroup a => a -> a -> a
<> Text
"`]")
| Attachment
a <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Seq Attachment)
mAttachments)
]
withParent :: Widget Name -> Widget Name
withParent Widget Name
p =
case ThreadState
mdThreadState of
ThreadState
NoThread -> Widget Name
msgWidget
ThreadState
InThreadShowParent -> Widget Name
p forall n. Widget n -> Widget n -> Widget n
<=> Widget Name
replyIndent
ThreadState
InThread -> Widget Name
replyIndent
in forall a. Widget a -> Widget a
freezeBorders forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not Bool
mdRenderReplyParent
then Widget Name
msgWidget
else case Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message ReplyState
mInReplyToMsg of
ReplyState
NotAReply -> Widget Name
msgWidget
InReplyTo PostId
_ ->
case Maybe Message
mdParentMessage of
Maybe Message
Nothing -> Widget Name -> Widget Name
withParent (forall n. String -> Widget n
str String
"[loading...]")
Just Message
pm ->
let parentMsg :: Widget Name
parentMsg = MessageData -> Widget Name
renderMessage MessageData
md
{ mdShowOlderEdits :: Bool
mdShowOlderEdits = Bool
False
, mdMessage :: Message
mdMessage = Message
pm
, mdUserName :: Maybe Text
mdUserName = Maybe Text
mdParentUserName
, mdParentMessage :: Maybe Message
mdParentMessage = forall a. Maybe a
Nothing
, mdRenderReplyParent :: Bool
mdRenderReplyParent = Bool
False
, mdIndentBlocks :: Bool
mdIndentBlocks = Bool
False
}
in Widget Name -> Widget Name
withParent (forall a. Widget a -> Widget a
addEllipsis forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
forceAttr AttrName
replyParentAttr Widget Name
parentMsg)
where
renderBlocks :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq Block
-> ViewL Block -> Widget Name
renderBlocks :: HighlightSet
-> Maybe Int
-> [Widget Name]
-> Seq Block
-> ViewL Block
-> Widget Name
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs ViewL Block
xs | forall (t :: * -> *) a. Foldable t => t a -> Int
length ViewL Block
xs forall a. Ord a => a -> a -> Bool
> Int
1 = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (Blockquote {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (CodeBlock {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (HTMLBlock {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (List {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (Para Inlines
inlns :< Seq Block
_)
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.any Inline -> Bool
isBreak (Inlines -> Seq Inline
unInlines Inlines
inlns) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
renderBlocks HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs ViewL Block
_ = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
nameNextToMessage HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
multiLnLayout :: HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs =
if Bool
mdIndentBlocks
then forall n. [Widget n] -> Widget n
vBox [ forall n. [Widget n] -> Widget n
hBox [Widget Name]
nameElems
, forall n. [Widget n] -> Widget n
hBox [forall n. Text -> Widget n
txt Text
" ", forall a.
SemEq a =>
Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> Blocks
-> Widget a
renderRichText Text
mdMyUsername HighlightSet
hs ((forall a. Num a => a -> a -> a
subtract Int
2) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
w)
Bool
mdWrapNonhighlightedCodeBlocks
Maybe Int
mdTruncateVerbatimBlocks
(forall a. a -> Maybe a
Just (Maybe MessageId -> Name -> Int -> Inline -> Maybe Name
mkClickableInline (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId) Name
mdClickableNameTag)) (Seq Block -> Blocks
Blocks Seq Block
bs)]
]
else HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
nameNextToMessage HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
nameNextToMessage :: HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
nameNextToMessage HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Result Name
nameResult <- forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
hBox [Widget Name]
nameElems
let newW :: Maybe Int
newW = forall a. Num a => a -> a -> a
subtract (Image -> Int
V.imageWidth (Result Name
nameResultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
w
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
hBox [ forall n. Result n -> Widget n
resultToWidget Result Name
nameResult
, forall a.
SemEq a =>
Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> Blocks
-> Widget a
renderRichText Text
mdMyUsername HighlightSet
hs Maybe Int
newW
Bool
mdWrapNonhighlightedCodeBlocks
Maybe Int
mdTruncateVerbatimBlocks
(forall a. a -> Maybe a
Just (Maybe MessageId -> Name -> Int -> Inline -> Maybe Name
mkClickableInline (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId) Name
mdClickableNameTag)) (Seq Block -> Blocks
Blocks Seq Block
bs)
]
isBreak :: Inline -> Bool
isBreak Inline
i = Inline
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Inline
ELineBreak, Inline
ESoftBreak]
mkClickableInline :: Maybe MessageId -> Name -> Int -> Inline -> Maybe Name
mkClickableInline :: Maybe MessageId -> Name -> Int -> Inline -> Maybe Name
mkClickableInline Maybe MessageId
mmId Name
scope Int
i (EHyperlink URL
u Inlines
_) = do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe MessageId -> Name -> Int -> LinkTarget -> Name
ClickableURL Maybe MessageId
mmId Name
scope Int
i forall a b. (a -> b) -> a -> b
$ URL -> LinkTarget
LinkURL URL
u
mkClickableInline Maybe MessageId
mmId Name
scope Int
i (EUser Text
name) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe MessageId -> Name -> Int -> Text -> Name
ClickableUsername Maybe MessageId
mmId Name
scope Int
i Text
name
mkClickableInline Maybe MessageId
mmId Name
scope Int
i (EPermalink TeamURLName
teamUrlName PostId
pId Maybe Inlines
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe MessageId -> Name -> Int -> LinkTarget -> Name
ClickableURL Maybe MessageId
mmId Name
scope Int
i forall a b. (a -> b) -> a -> b
$ TeamURLName -> PostId -> LinkTarget
LinkPermalink TeamURLName
teamUrlName PostId
pId
mkClickableInline Maybe MessageId
_ Name
_ Int
_ Inline
_ =
forall a. Maybe a
Nothing
messageReactions :: MessageData -> Maybe (Widget Name)
messageReactions :: MessageData -> Maybe (Widget Name)
messageReactions MessageData { mdMessage :: MessageData -> Message
mdMessage = Message
msg, Bool
Maybe Int
Maybe Text
Maybe ServerTime
Maybe Message
Text
UserId
Name
ThreadState
HighlightSet
mdClickableNameTag :: Name
mdWrapNonhighlightedCodeBlocks :: Bool
mdMyUserId :: UserId
mdMyUsername :: Text
mdMessageWidthLimit :: Maybe Int
mdTruncateVerbatimBlocks :: Maybe Int
mdIndentBlocks :: Bool
mdHighlightSet :: HighlightSet
mdRenderReplyIndent :: Bool
mdRenderReplyParent :: Bool
mdThreadState :: ThreadState
mdParentUserName :: Maybe Text
mdParentMessage :: Maybe Message
mdUserName :: Maybe Text
mdShowReactions :: Bool
mdShowOlderEdits :: Bool
mdEditThreshold :: Maybe ServerTime
mdClickableNameTag :: MessageData -> Name
mdWrapNonhighlightedCodeBlocks :: MessageData -> Bool
mdMyUserId :: MessageData -> UserId
mdMyUsername :: MessageData -> Text
mdMessageWidthLimit :: MessageData -> Maybe Int
mdTruncateVerbatimBlocks :: MessageData -> Maybe Int
mdIndentBlocks :: MessageData -> Bool
mdHighlightSet :: MessageData -> HighlightSet
mdRenderReplyIndent :: MessageData -> Bool
mdRenderReplyParent :: MessageData -> Bool
mdThreadState :: MessageData -> ThreadState
mdParentUserName :: MessageData -> Maybe Text
mdParentMessage :: MessageData -> Maybe Message
mdUserName :: MessageData -> Maybe Text
mdShowReactions :: MessageData -> Bool
mdShowOlderEdits :: MessageData -> Bool
mdEditThreshold :: MessageData -> Maybe ServerTime
.. } =
if forall k a. Map k a -> Bool
Map.null (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Map Text (Set UserId))
mReactions) Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
mdShowReactions)
then forall a. Maybe a
Nothing
else let renderR :: Text -> Set UserId -> [Widget Name] -> [Widget Name]
renderR Text
e Set UserId
us [Widget Name]
lst =
let n :: Int
n = forall a. Set a -> Int
Set.size Set UserId
us
mine :: Bool
mine = Set UserId -> Bool
isMyReaction Set UserId
us
content :: Text
content = if | Int
n forall a. Eq a => a -> a -> Bool
== Int
1 -> Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
e forall a. Semigroup a => a -> a -> a
<> Text
"]"
| Bool
otherwise -> Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
e forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
n) forall a. Semigroup a => a -> a -> a
<> Text
"]"
w :: Widget Name
w = Bool -> Text -> Set UserId -> Text -> Widget Name
makeReactionWidget Bool
mine Text
e Set UserId
us Text
content
in forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) Widget Name
w forall a. a -> [a] -> [a]
: [Widget Name]
lst
nonEmptyReactions :: Map Text (Set UserId)
nonEmptyReactions = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) forall a b. (a -> b) -> a -> b
$ Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Map Text (Set UserId))
mReactions
isMyReaction :: Set UserId -> Bool
isMyReaction = forall a. Ord a => a -> Set a -> Bool
Set.member UserId
mdMyUserId
makeReactionWidget :: Bool -> Text -> Set UserId -> Text -> Widget Name
makeReactionWidget Bool
mine Text
e Set UserId
us Text
t =
let w :: Widget n
w = forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
attr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
t
attr :: AttrName
attr = if Bool
mine then AttrName
myReactionAttr else AttrName
reactionAttr
in forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall n. Widget n
w (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall n. Ord n => n -> Widget n -> Widget n
clickable forall n. Widget n
w) forall a b. (a -> b) -> a -> b
$ Text -> Set UserId -> Maybe Name
makeName Text
e Set UserId
us
hasAnyReactions :: Bool
hasAnyReactions = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text (Set UserId)
nonEmptyReactions
makeName :: Text -> Set UserId -> Maybe Name
makeName Text
e Set UserId
us = do
PostId
pid <- Post -> PostId
postId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe Post)
mOriginalPost
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PostId -> Name -> Text -> Set UserId -> Name
ClickableReaction PostId
pid Name
mdClickableNameTag Text
e Set UserId
us
reactionWidget :: Widget Name
reactionWidget = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Context Name
ctx <- forall n. RenderM n (Context n)
getContext
let lineW :: Int
lineW = Context Name
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availWidthL
[Result Name]
reacs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Text -> Set UserId -> [Widget Name] -> [Widget Name]
renderR [] Map Text (Set UserId)
nonEmptyReactions
let reacLines :: [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines :: forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [Result n]
l Int
_ [] = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Result n]
l then [] else [[Result n]
l]
reacLines [Result n]
l Int
w (Result n
r:[Result n]
rs) =
let rW :: Int
rW = Image -> Int
V.imageWidth forall a b. (a -> b) -> a -> b
$ Result n
rforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL
in if Int
rW forall a. Ord a => a -> a -> Bool
<= Int
w
then forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines ([Result n]
l forall a. Semigroup a => a -> a -> a
<> [Result n
r]) (Int
w forall a. Num a => a -> a -> a
- Int
rW) [Result n]
rs
else if Int
rW forall a. Ord a => a -> a -> Bool
> Int
lineW
then [Result n]
l forall a. a -> [a] -> [a]
: [Result n
r] forall a. a -> [a] -> [a]
: forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [] Int
lineW [Result n]
rs
else [Result n]
l forall a. a -> [a] -> [a]
: forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [] Int
lineW (Result n
rforall a. a -> [a] -> [a]
:[Result n]
rs)
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
hBox forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Result n -> Widget n
resultToWidget)) (forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [] Int
lineW [Result Name]
reacs)
in if Bool
hasAnyReactions
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
" " forall n. Widget n -> Widget n -> Widget n
<+> Widget Name
reactionWidget
else forall a. Maybe a
Nothing
addEditSentinel :: Inline -> Blocks -> Blocks
addEditSentinel :: Inline -> Blocks -> Blocks
addEditSentinel Inline
d (Blocks Seq Block
bs) =
case forall a. Seq a -> ViewR a
viewr Seq Block
bs of
ViewR Block
EmptyR -> Seq Block -> Blocks
Blocks Seq Block
bs
(Seq Block
rest :> Block
b) -> Seq Block -> Blocks
Blocks Seq Block
rest forall a. Semigroup a => a -> a -> a
<> Inline -> Block -> Blocks
appendEditSentinel Inline
d Block
b
appendEditSentinel :: Inline -> Block -> Blocks
appendEditSentinel :: Inline -> Block -> Blocks
appendEditSentinel Inline
sentinel Block
b =
let s :: Block
s = Inlines -> Block
Para (Seq Inline -> Inlines
Inlines forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
S.singleton Inline
sentinel)
in Seq Block -> Blocks
Blocks forall a b. (a -> b) -> a -> b
$ case Block
b of
Para Inlines
is -> forall a. a -> Seq a
S.singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Block
Para (Seq Inline -> Inlines
Inlines forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
unInlines Inlines
is forall a. Seq a -> a -> Seq a
|> Inline
ESpace forall a. Seq a -> a -> Seq a
|> Inline
sentinel)
Block
_ -> forall a. [a] -> Seq a
S.fromList [Block
b, Block
s]
omittedUsernameType :: MessageType -> Bool
omittedUsernameType :: MessageType -> Bool
omittedUsernameType = \case
CP ClientPostType
Join -> Bool
True
CP ClientPostType
Leave -> Bool
True
CP ClientPostType
TopicChange -> Bool
True
MessageType
_ -> Bool
False
addEllipsis :: Widget a -> Widget a
addEllipsis :: forall a. Widget a -> Widget a
addEllipsis Widget a
w = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget (forall n. Widget n -> Size
hSize Widget a
w) (forall n. Widget n -> Size
vSize Widget a
w) forall a b. (a -> b) -> a -> b
$ do
Context a
ctx <- forall n. RenderM n (Context n)
getContext
let aw :: Int
aw = Context a
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availWidthL
Result a
result <- forall n. Widget n -> RenderM n (Result n)
render Widget a
w
let withEllipsis :: Widget a
withEllipsis = (forall n. Int -> Widget n -> Widget n
hLimit (Int
aw forall a. Num a => a -> a -> a
- Int
3) forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
vLimit Int
1 forall a b. (a -> b) -> a -> b
$ (forall n. Result n -> Widget n
resultToWidget Result a
result)) forall n. Widget n -> Widget n -> Widget n
<+>
forall n. String -> Widget n
str String
"..."
if (Image -> Int
V.imageHeight (Result a
resultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL) forall a. Ord a => a -> a -> Bool
> Int
1) Bool -> Bool -> Bool
|| (Image -> Int
V.imageWidth (Result a
resultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL) forall a. Eq a => a -> a -> Bool
== Int
aw) then
forall n. Widget n -> RenderM n (Result n)
render Widget a
withEllipsis else
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
result