{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Matterhorn.Draw.Messages
( MessageData(..)
, renderMessage
, nameForUserRef
, renderSingleMessage
, unsafeRenderMessageSelection
, renderLastMessages
, addEllipsis
)
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 qualified Graphics.Vty as V
import Lens.Micro.Platform ( (.~), to )
import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )
import Network.Mattermost.Types ( ServerTime(..), userUsername )
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
maxMessageHeight :: Int
maxMessageHeight :: Int
maxMessageHeight = Int
200
nameForUserRef :: ChatState -> UserRef -> Maybe Text
nameForUserRef :: ChatState -> UserRef -> Maybe Text
nameForUserRef ChatState
st UserRef
uref =
case UserRef
uref of
UserRef
NoUser -> Maybe Text
forall a. Maybe a
Nothing
UserOverride Bool
_ Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
UserI Bool
_ UserId
uId -> UserId -> ChatState -> Maybe Text
displayNameForUserId UserId
uId ChatState
st
renderSingleMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> Message
-> ThreadState
-> Widget Name
renderSingleMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> Message
-> ThreadState
-> Widget Name
renderSingleMessage ChatState
st HighlightSet
hs Maybe ServerTime
ind Message
m ThreadState
threadState =
ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> (ServerTime -> Widget Name)
-> Message
-> Widget Name
renderChatMessage ChatState
st HighlightSet
hs Maybe ServerTime
ind ThreadState
threadState (Widget Name -> Widget Name
forall a. Widget a -> Widget a
withBrackets (Widget Name -> Widget Name)
-> (ServerTime -> Widget Name) -> ServerTime -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatState -> UTCTime -> Widget Name
renderTime ChatState
st (UTCTime -> Widget Name)
-> (ServerTime -> UTCTime) -> ServerTime -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerTime -> UTCTime
withServerTime) Message
m
renderChatMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> (ServerTime -> Widget Name)
-> Message
-> Widget Name
renderChatMessage :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> ThreadState
-> (ServerTime -> Widget Name)
-> Message
-> Widget Name
renderChatMessage ChatState
st HighlightSet
hs Maybe ServerTime
ind ThreadState
threadState ServerTime -> Widget Name
renderTimeFunc Message
msg =
let showOlderEdits :: Bool
showOlderEdits = Config -> Bool
configShowOlderEdits Config
config
showTimestamp :: Bool
showTimestamp = Config -> Bool
configShowMessageTimestamps Config
config
config :: Config
config = ChatState
stChatState -> Getting Config ChatState Config -> Config
forall s a. s -> Getting a s a -> a
^.(ChatResources -> Const Config ChatResources)
-> ChatState -> Const Config ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const Config ChatResources)
-> ChatState -> Const Config ChatState)
-> ((Config -> Const Config Config)
-> ChatResources -> Const Config ChatResources)
-> Getting Config ChatState Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Const Config Config)
-> ChatResources -> Const Config ChatResources
Lens' ChatResources Config
crConfiguration
parent :: Maybe Message
parent = case Message
msgMessage -> Getting ReplyState Message ReplyState -> ReplyState
forall s a. s -> Getting a s a -> a
^.Getting ReplyState Message ReplyState
Lens' Message ReplyState
mInReplyToMsg of
ReplyState
NotAReply -> Maybe Message
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 :: Maybe ServerTime
-> Bool
-> Bool
-> Message
-> Maybe Text
-> Maybe Message
-> Maybe Text
-> ThreadState
-> Bool
-> HighlightSet
-> Bool
-> Maybe Int
-> Text
-> Bool
-> MessageData
MessageData
{ mdMessage :: Message
mdMessage = Message
msg
, mdUserName :: Maybe Text
mdUserName = Message
msgMessage -> Getting (Maybe Text) Message (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.(UserRef -> Const (Maybe Text) UserRef)
-> Message -> Const (Maybe Text) Message
Lens' Message UserRef
mUser((UserRef -> Const (Maybe Text) UserRef)
-> Message -> Const (Maybe Text) Message)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
-> UserRef -> Const (Maybe Text) UserRef)
-> Getting (Maybe Text) Message (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UserRef -> Maybe Text) -> SimpleGetter UserRef (Maybe Text)
forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
nameForUserRef ChatState
st)
, mdParentMessage :: Maybe Message
mdParentMessage = Maybe Message
parent
, mdParentUserName :: Maybe Text
mdParentUserName = Maybe Message
parent Maybe Message -> (Message -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Message -> Getting (Maybe Text) Message (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.(UserRef -> Const (Maybe Text) UserRef)
-> Message -> Const (Maybe Text) Message
Lens' Message UserRef
mUser((UserRef -> Const (Maybe Text) UserRef)
-> Message -> Const (Maybe Text) Message)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
-> UserRef -> Const (Maybe Text) UserRef)
-> Getting (Maybe Text) Message (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UserRef -> Maybe Text) -> SimpleGetter UserRef (Maybe Text)
forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
nameForUserRef ChatState
st))
, mdEditThreshold :: Maybe ServerTime
mdEditThreshold = Maybe ServerTime
ind
, mdHighlightSet :: HighlightSet
mdHighlightSet = HighlightSet
hs
, mdShowOlderEdits :: Bool
mdShowOlderEdits = Bool
showOlderEdits
, mdRenderReplyParent :: Bool
mdRenderReplyParent = Bool
True
, mdIndentBlocks :: Bool
mdIndentBlocks = Bool
True
, mdThreadState :: ThreadState
mdThreadState = ThreadState
threadState
, mdShowReactions :: Bool
mdShowReactions = Bool
True
, mdMessageWidthLimit :: Maybe Int
mdMessageWidthLimit = Maybe Int
forall a. Maybe a
Nothing
, mdMyUsername :: Text
mdMyUsername = User -> Text
userUsername (User -> Text) -> User -> Text
forall a b. (a -> b) -> a -> b
$ ChatState -> User
myUser ChatState
st
, mdWrapNonhighlightedCodeBlocks :: Bool
mdWrapNonhighlightedCodeBlocks = Bool
True
}
fullMsg :: Widget Name
fullMsg =
case Message
msgMessage -> Getting UserRef Message UserRef -> UserRef
forall s a. s -> Getting a s a -> a
^.Getting UserRef Message UserRef
Lens' Message UserRef
mUser of
UserRef
NoUser
| Message -> Bool
isGap Message
msg -> AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
gapMessageAttr Widget Name
m
| Bool
otherwise ->
case Message
msgMessage -> Getting MessageType Message MessageType -> MessageType
forall s a. s -> Getting a s a -> a
^.Getting MessageType Message MessageType
Lens' Message MessageType
mType of
C ClientMessageType
DateTransition ->
AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
dateTransitionAttr (Widget Name -> Widget Name
forall a. Widget a -> Widget a
hBorderWithLabel Widget Name
m)
C ClientMessageType
NewMessagesTransition ->
AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
newMessageTransitionAttr (Widget Name -> Widget Name
forall a. Widget a -> Widget a
hBorderWithLabel Widget Name
m)
C ClientMessageType
Error ->
AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
errorMessageAttr Widget Name
m
MessageType
_ ->
AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr Widget Name
m
UserRef
_ | Message -> Bool
isJoinLeave Message
msg -> AttrName -> Widget Name -> Widget Name
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 ThreadState -> ThreadState -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadState
InThreadShowParent
then (Text -> Widget n
forall n. Text -> Widget n
txt Text
" " Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<=>) else Widget n -> Widget n
forall a. a -> a
id
in [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox [Widget Name -> Widget Name
forall a. Widget a -> Widget a
maybePadTime (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ ServerTime -> Widget Name
renderTimeFunc (Message
msgMessage -> Getting ServerTime Message ServerTime -> ServerTime
forall s a. s -> Getting a s a -> a
^.Getting ServerTime Message ServerTime
Lens' Message ServerTime
mDate), Text -> Widget Name
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 a -> a
forall a. a -> a
id else a -> a
f
in (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a. (a -> a) -> a -> a
maybeRenderTimeWith Widget Name -> Widget Name
maybeRenderTime Widget Name
fullMsg
unsafeRenderMessageSelection :: (Foldable f, Foldable g)
=> ((Message, ThreadState), (f (Message, ThreadState), g (Message, ThreadState)))
-> (Message -> ThreadState -> Widget Name)
-> Widget Name
unsafeRenderMessageSelection :: ((Message, ThreadState),
(f (Message, ThreadState), g (Message, ThreadState)))
-> (Message -> ThreadState -> Widget Name) -> Widget Name
unsafeRenderMessageSelection ((Message
curMsg, ThreadState
curThreadState), (f (Message, ThreadState)
before, g (Message, ThreadState)
after)) Message -> ThreadState -> Widget Name
doMsgRender =
Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- RenderM Name Context
forall n. RenderM n Context
getContext
Result Name
curMsgResult <- (Context -> Context)
-> RenderM Name (Result Name) -> RenderM Name (Result Name)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT Context -> Context
relaxHeight (RenderM Name (Result Name) -> RenderM Name (Result Name))
-> RenderM Name (Result Name) -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$
AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
forceAttr AttrName
messageSelectAttr (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padRight Padding
Max (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Message -> ThreadState -> Widget Name
doMsgRender Message
curMsg ThreadState
curThreadState
let targetHeight :: Int
targetHeight = Context
ctxContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
availHeightL
upperHeight :: Int
upperHeight = Int
targetHeight Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
lowerHeight :: Int
lowerHeight = Int
targetHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
upperHeight
lowerRender :: Image -> (Message, ThreadState) -> RenderM Name Image
lowerRender Image
img (Message
m, ThreadState
tState) = (Message -> ThreadState -> Widget Name)
-> (Image -> Image -> Image)
-> Int
-> Image
-> ThreadState
-> Message
-> RenderM Name Image
render1HLimit Message -> ThreadState -> Widget Name
doMsgRender Image -> Image -> Image
V.vertJoin Int
targetHeight Image
img ThreadState
tState Message
m
upperRender :: Image -> (Message, ThreadState) -> RenderM Name Image
upperRender Image
img (Message
m, ThreadState
tState) = (Message -> ThreadState -> Widget Name)
-> (Image -> Image -> Image)
-> Int
-> Image
-> ThreadState
-> Message
-> RenderM Name Image
render1HLimit Message -> ThreadState -> Widget Name
doMsgRender ((Image -> Image -> Image) -> Image -> Image -> Image
forall a b c. (a -> b -> c) -> b -> a -> c
flip Image -> Image -> Image
V.vertJoin) Int
targetHeight Image
img ThreadState
tState Message
m
Image
lowerHalf <- (Image -> (Message, ThreadState) -> RenderM Name Image)
-> Image -> g (Message, ThreadState) -> RenderM Name Image
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Image -> (Message, ThreadState) -> RenderM Name Image
lowerRender Image
V.emptyImage g (Message, ThreadState)
after
Image
upperHalf <- (Image -> (Message, ThreadState) -> RenderM Name Image)
-> Image -> f (Message, ThreadState) -> RenderM Name Image
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Image -> (Message, ThreadState) -> RenderM Name Image
upperRender Image
V.emptyImage f (Message, ThreadState)
before
let curHeight :: Int
curHeight = Image -> Int
V.imageHeight (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result Name
curMsgResultResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL
uncropped :: Image
uncropped = Image
upperHalf Image -> Image -> Image
V.<-> Result Name
curMsgResultResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL Image -> Image -> Image
V.<-> Image
lowerHalf
img :: Image
img = if | Image -> Int
V.imageHeight Image
lowerHalf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
lowerHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curHeight) ->
Int -> Image -> Image
V.cropTop Int
targetHeight Image
uncropped
| Image -> Int
V.imageHeight Image
upperHalf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
upperHeight ->
Int -> Image -> Image
V.cropBottom Int
targetHeight Image
uncropped
| Bool
otherwise ->
Int -> Image -> Image
V.cropTop Int
upperHeight Image
upperHalf Image -> Image -> Image
V.<-> Result Name
curMsgResultResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL Image -> Image -> Image
V.<->
(if Int
curHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lowerHeight
then Int -> Image -> Image
V.cropBottom (Int
lowerHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curHeight) Image
lowerHalf
else Int -> Image -> Image
V.cropBottom Int
lowerHeight Image
lowerHalf)
Result Name -> RenderM Name (Result Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Name -> RenderM Name (Result Name))
-> Result Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Result Name
forall n. Result n
emptyResult Result Name -> (Result Name -> Result Name) -> Result Name
forall a b. a -> (a -> b) -> b
& (Image -> Identity Image) -> Result Name -> Identity (Result Name)
forall n. Lens' (Result n) Image
imageL ((Image -> Identity Image)
-> Result Name -> Identity (Result Name))
-> Image -> Result Name -> Result Name
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Image
img
renderLastMessages :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages :: ChatState
-> HighlightSet
-> Maybe ServerTime
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages ChatState
st HighlightSet
hs Maybe ServerTime
editCutoff DirectionalSeq Retrograde (Message, ThreadState)
msgs =
Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- RenderM Name Context
forall n. RenderM n Context
getContext
let targetHeight :: Int
targetHeight = Context
ctxContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
availHeightL
doMsgRender :: Message -> ThreadState -> Widget Name
doMsgRender = ChatState
-> HighlightSet
-> Maybe ServerTime
-> Message
-> ThreadState
-> Widget Name
renderSingleMessage ChatState
st HighlightSet
hs Maybe ServerTime
editCutoff
newMessagesTransitions :: DirectionalSeq Retrograde (Message, ThreadState)
newMessagesTransitions = ((Message, ThreadState) -> Bool)
-> DirectionalSeq Retrograde (Message, ThreadState)
-> DirectionalSeq Retrograde (Message, ThreadState)
forall seq a.
SeqDirection seq =>
(a -> Bool) -> DirectionalSeq seq a -> DirectionalSeq seq a
filterMessages (Message -> Bool
isNewMessagesTransition (Message -> Bool)
-> ((Message, ThreadState) -> Message)
-> (Message, ThreadState)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message, ThreadState) -> Message
forall a b. (a, b) -> a
fst) DirectionalSeq Retrograde (Message, ThreadState)
msgs
newMessageTransition :: Maybe Message
newMessageTransition = (Message, ThreadState) -> Message
forall a b. (a, b) -> a
fst ((Message, ThreadState) -> Message)
-> Maybe (Message, ThreadState) -> Maybe Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Message, ThreadState)] -> Maybe (Message, ThreadState)
forall a. [a] -> Maybe a
listToMaybe ([(Message, ThreadState)] -> Maybe (Message, ThreadState))
-> [(Message, ThreadState)] -> Maybe (Message, ThreadState)
forall a b. (a -> b) -> a -> b
$ DirectionalSeq Retrograde (Message, ThreadState)
-> [(Message, ThreadState)]
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
mMessage -> Getting ServerTime Message ServerTime -> ServerTime
forall s a. s -> Getting a s a -> a
^.Getting ServerTime Message ServerTime
Lens' Message ServerTime
mDate ServerTime -> ServerTime -> Bool
forall a. Ord a => a -> a -> Bool
> Message
transitionMessage -> Getting ServerTime Message ServerTime -> ServerTime
forall s a. s -> Getting a s a -> a
^.Getting ServerTime Message ServerTime
Lens' Message ServerTime
mDate
go :: V.Image -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name V.Image
go :: Image
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name Image
go Image
img DirectionalSeq Retrograde (Message, ThreadState)
ms | DirectionalSeq Retrograde (Message, ThreadState) -> Int
forall seq a. DirectionalSeq seq a -> Int
messagesLength DirectionalSeq Retrograde (Message, ThreadState)
ms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Image -> RenderM Name Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
img
go Image
img DirectionalSeq Retrograde (Message, ThreadState)
ms = do
let Just (Message
m, ThreadState
threadState) = DirectionalSeq Retrograde (Message, ThreadState)
-> Maybe (Message, ThreadState)
forall seq a. SeqDirection seq => DirectionalSeq seq a -> Maybe a
messagesHead DirectionalSeq Retrograde (Message, ThreadState)
ms
newMessagesAbove :: Bool
newMessagesAbove = Bool -> (Message -> Bool) -> Maybe Message -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Message -> Message -> Bool
isBelow Message
m) Maybe Message
newMessageTransition
Image
newImg <- (Message -> ThreadState -> Widget Name)
-> (Image -> Image -> Image)
-> Int
-> Image
-> ThreadState
-> Message
-> RenderM Name Image
render1HLimit Message -> ThreadState -> Widget Name
doMsgRender ((Image -> Image -> Image) -> Image -> Image -> Image
forall a b c. (a -> b -> c) -> b -> a -> c
flip Image -> Image -> Image
V.vertJoin) Int
targetHeight Image
img ThreadState
threadState Message
m
if Image -> Int
V.imageHeight Image
newImg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetHeight Bool -> Bool -> Bool
&& Bool
newMessagesAbove
then do
Result Name
transitionResult <- Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
newMessageTransitionAttr (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
Widget Name -> Widget Name
forall a. Widget a -> Widget a
hBorderWithLabel (Text -> Widget Name
forall n. Text -> Widget n
txt Text
"New Messages ↑")
let newImg2 :: Image
newImg2 = Image -> Image -> Image
V.vertJoin (Result Name
transitionResultResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL)
(Int -> Image -> Image
V.cropTop (Int
targetHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Image
newImg)
Image -> RenderM Name Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
newImg2
else Image
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name Image
go Image
newImg (DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name Image)
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name Image
forall a b. (a -> b) -> a -> b
$ Int
-> DirectionalSeq Retrograde (Message, ThreadState)
-> DirectionalSeq Retrograde (Message, ThreadState)
forall seq a.
SeqDirection seq =>
Int -> DirectionalSeq seq a -> DirectionalSeq seq a
messagesDrop Int
1 DirectionalSeq Retrograde (Message, ThreadState)
ms
Image
img <- Image
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name Image
go Image
V.emptyImage DirectionalSeq Retrograde (Message, ThreadState)
msgs
Result Name -> RenderM Name (Result Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Name -> RenderM Name (Result Name))
-> Result Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Result Name
forall n. Result n
emptyResult Result Name -> (Result Name -> Result Name) -> Result Name
forall a b. a -> (a -> b) -> b
& (Image -> Identity Image) -> Result Name -> Identity (Result Name)
forall n. Lens' (Result n) Image
imageL ((Image -> Identity Image)
-> Result Name -> Identity (Result Name))
-> Image -> Result Name -> Result Name
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Int -> Image -> Image
V.cropTop Int
targetHeight Image
img)
relaxHeight :: Context -> Context
relaxHeight :: Context -> Context
relaxHeight Context
c = Context
c Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Context -> Identity Context
Lens' Context Int
availHeightL ((Int -> Identity Int) -> Context -> Identity Context)
-> Int -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxMessageHeight (Context
cContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
availHeightL))
render1HLimit :: (Message -> ThreadState -> Widget Name)
-> (V.Image -> V.Image -> V.Image)
-> Int
-> V.Image
-> ThreadState
-> Message
-> RenderM Name V.Image
render1HLimit :: (Message -> ThreadState -> Widget Name)
-> (Image -> Image -> Image)
-> Int
-> Image
-> ThreadState
-> Message
-> RenderM Name Image
render1HLimit Message -> ThreadState -> Widget Name
doMsgRender Image -> Image -> Image
fjoin Int
lim Image
img ThreadState
threadState Message
msg
| Image -> Int
V.imageHeight Image
img Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lim = Image -> RenderM Name Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
img
| Bool
otherwise = Image -> Image -> Image
fjoin Image
img (Image -> Image) -> RenderM Name Image -> RenderM Name Image
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message -> ThreadState -> Widget Name)
-> ThreadState -> Message -> RenderM Name Image
render1 Message -> ThreadState -> Widget Name
doMsgRender ThreadState
threadState Message
msg
render1 :: (Message -> ThreadState -> Widget Name)
-> ThreadState
-> Message
-> RenderM Name V.Image
render1 :: (Message -> ThreadState -> Widget Name)
-> ThreadState -> Message -> RenderM Name Image
render1 Message -> ThreadState -> Widget Name
doMsgRender ThreadState
threadState Message
msg = case Message
msgMessage -> Getting Bool Message Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Message Bool
Lens' Message Bool
mDeleted of
Bool
True -> Image -> RenderM Name Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
V.emptyImage
Bool
False -> do
Result Name
r <- (Context -> Context)
-> RenderM Name (Result Name) -> RenderM Name (Result Name)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT Context -> Context
relaxHeight (RenderM Name (Result Name) -> RenderM Name (Result Name))
-> RenderM Name (Result Name) -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$
Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padRight Padding
Max (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
Message -> ThreadState -> Widget Name
doMsgRender Message
msg ThreadState
threadState
Image -> RenderM Name Image
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> RenderM Name Image) -> Image -> RenderM Name Image
forall a b. (a -> b) -> a -> b
$ Result Name
rResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL
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 -> HighlightSet
mdHighlightSet :: HighlightSet
, MessageData -> Bool
mdIndentBlocks :: Bool
, MessageData -> Maybe Int
mdMessageWidthLimit :: Maybe Int
, MessageData -> Text
mdMyUsername :: Text
, MessageData -> Bool
mdWrapNonhighlightedCodeBlocks :: Bool
}
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
ThreadState
HighlightSet
mdWrapNonhighlightedCodeBlocks :: Bool
mdMyUsername :: Text
mdMessageWidthLimit :: Maybe Int
mdIndentBlocks :: Bool
mdHighlightSet :: HighlightSet
mdRenderReplyParent :: Bool
mdThreadState :: ThreadState
mdParentUserName :: Maybe Text
mdParentMessage :: Maybe Message
mdUserName :: Maybe Text
mdShowReactions :: Bool
mdShowOlderEdits :: Bool
mdEditThreshold :: Maybe ServerTime
mdWrapNonhighlightedCodeBlocks :: MessageData -> Bool
mdMyUsername :: MessageData -> Text
mdMessageWidthLimit :: MessageData -> Maybe Int
mdShowReactions :: MessageData -> Bool
mdThreadState :: MessageData -> ThreadState
mdIndentBlocks :: MessageData -> Bool
mdRenderReplyParent :: MessageData -> Bool
mdShowOlderEdits :: MessageData -> Bool
mdHighlightSet :: MessageData -> HighlightSet
mdEditThreshold :: MessageData -> Maybe ServerTime
mdParentUserName :: MessageData -> Maybe Text
mdParentMessage :: MessageData -> Maybe Message
mdUserName :: MessageData -> Maybe Text
.. } =
let msgUsr :: Maybe Text
msgUsr = case Maybe Text
mdUserName of
Just Text
u -> if MessageType -> Bool
omittedUsernameType (Message
msgMessage -> Getting MessageType Message MessageType -> MessageType
forall s a. s -> Getting a s a -> a
^.Getting MessageType Message MessageType
Lens' Message MessageType
mType) then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
u
Maybe Text
Nothing -> Maybe Text
forall a. Maybe a
Nothing
botElem :: Widget n
botElem = if Message -> Bool
isBotMessage Message
msg then Text -> Widget n
forall n. Text -> Widget n
txt Text
"[BOT]" else Widget n
forall n. Widget n
emptyWidget
nameElems :: [Widget n]
nameElems = case Maybe Text
msgUsr of
Just Text
un
| Message -> Bool
isEmote Message
msg ->
[ AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
pinnedMessageIndicatorAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ if Message
msgMessage -> Getting Bool Message Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Message Bool
Lens' Message Bool
mPinned then Text
"[PIN]" else Text
""
, Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ (if Message
msgMessage -> Getting Bool Message Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Message Bool
Lens' Message Bool
mFlagged then Text
"[!] " else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*"
, Text -> Text -> Text -> Widget n
forall a. Text -> Text -> Text -> Widget a
colorUsername Text
mdMyUsername Text
un Text
un
, Widget n
forall n. Widget n
botElem
, Text -> Widget n
forall n. Text -> Widget n
txt Text
" "
]
| Bool
otherwise ->
[ AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
pinnedMessageIndicatorAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ if Message
msgMessage -> Getting Bool Message Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Message Bool
Lens' Message Bool
mPinned then Text
"[PIN] " else Text
""
, Text -> Text -> Text -> Widget n
forall a. Text -> Text -> Text -> Widget a
colorUsername Text
mdMyUsername Text
un Text
un
, Widget n
forall n. Widget n
botElem
, Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ (if Message
msgMessage -> Getting Bool Message Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Message Bool
Lens' Message Bool
mFlagged then Text
"[!]" else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
]
Maybe Text
Nothing -> []
maybeAugment :: Blocks -> Blocks
maybeAugment Blocks
bs = case Message
msgMessage -> Getting (Maybe Post) Message (Maybe Post) -> Maybe Post
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Post) Message (Maybe Post)
Lens' Message (Maybe Post)
mOriginalPost of
Maybe Post
Nothing -> Blocks
bs
Just Post
p ->
if Post
pPost -> Getting ServerTime Post ServerTime -> ServerTime
forall s a. s -> Getting a s a -> a
^.Getting ServerTime Post ServerTime
Lens' Post ServerTime
postEditAtL ServerTime -> ServerTime -> Bool
forall a. Ord a => a -> a -> Bool
> Post
pPost -> Getting ServerTime Post ServerTime -> ServerTime
forall s a. s -> Getting a s a -> a
^.Getting ServerTime Post ServerTime
Lens' Post ServerTime
postCreateAtL
then case Maybe ServerTime
mdEditThreshold of
Just ServerTime
cutoff | Post
pPost -> Getting ServerTime Post ServerTime -> ServerTime
forall s a. s -> Getting a s a -> a
^.Getting ServerTime Post ServerTime
Lens' Post ServerTime
postEditAtL ServerTime -> ServerTime -> Bool
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 (Blocks -> Seq Block) -> Blocks -> Seq Block
forall a b. (a -> b) -> a -> b
$ Blocks -> Blocks
maybeAugment (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$ Message
msgMessage -> Getting Blocks Message Blocks -> Blocks
forall s a. s -> Getting a s a -> a
^.Getting Blocks Message Blocks
Lens' Message Blocks
mText
msgWidget :: Widget Name
msgWidget =
[Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox ([Widget Name] -> Widget Name) -> [Widget Name] -> Widget Name
forall a b. (a -> b) -> a -> b
$ (HighlightSet
-> Maybe Int
-> [Widget Name]
-> Seq Block
-> ViewL Block
-> Widget Name
layout HighlightSet
mdHighlightSet Maybe Int
mdMessageWidthLimit [Widget Name]
forall n. [Widget n]
nameElems Seq Block
augmentedText (ViewL Block -> Widget Name)
-> (Seq Block -> ViewL Block) -> Seq Block -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Block -> ViewL Block
forall a. Seq a -> ViewL a
viewl) Seq Block
augmentedText Widget Name -> [Widget Name] -> [Widget Name]
forall a. a -> [a] -> [a]
:
[Maybe (Widget Name)] -> [Widget Name]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Widget Name)
forall n. Maybe (Widget n)
msgAtch, Maybe (Widget Name)
forall n. Maybe (Widget n)
msgReac]
replyIndent :: Widget Name
replyIndent = Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- RenderM Name Context
forall n. RenderM n Context
getContext
Result Name
w <- Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
hLimit (Context
ctxContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
availWidthL Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Widget Name
msgWidget
Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
vLimit (Image -> Int
V.imageHeight (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result Name
wResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL) (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) Widget Name
forall n. Widget n
vBorder Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<+> (Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ Result Name -> RenderM Name (Result Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Result Name
w)
msgAtch :: Maybe (Widget n)
msgAtch = if Seq Attachment -> Bool
forall a. Seq a -> Bool
S.null (Message
msgMessage
-> Getting (Seq Attachment) Message (Seq Attachment)
-> Seq Attachment
forall s a. s -> Getting a s a -> a
^.Getting (Seq Attachment) Message (Seq Attachment)
Lens' Message (Seq Attachment)
mAttachments)
then Maybe (Widget n)
forall a. Maybe a
Nothing
else Widget n -> Maybe (Widget n)
forall a. a -> Maybe a
Just (Widget n -> Maybe (Widget n)) -> Widget n -> Maybe (Widget n)
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox
[ Text -> Widget n
forall n. Text -> Widget n
txt (Text
" [attached: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attachment
aAttachment -> Getting Text Attachment Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Attachment Text
Lens' Attachment Text
attachmentName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`]")
| Attachment
a <- Seq Attachment -> [Attachment]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Message
msgMessage
-> Getting (Seq Attachment) Message (Seq Attachment)
-> Seq Attachment
forall s a. s -> Getting a s a -> a
^.Getting (Seq Attachment) Message (Seq Attachment)
Lens' Message (Seq Attachment)
mAttachments)
]
msgReac :: Maybe (Widget n)
msgReac = if Map Text (Set UserId) -> Bool
forall k a. Map k a -> Bool
Map.null (Message
msgMessage
-> Getting (Map Text (Set UserId)) Message (Map Text (Set UserId))
-> Map Text (Set UserId)
forall s a. s -> Getting a s a -> a
^.Getting (Map Text (Set UserId)) Message (Map Text (Set UserId))
Lens' Message (Map Text (Set UserId))
mReactions) Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
mdShowReactions)
then Maybe (Widget n)
forall a. Maybe a
Nothing
else let renderR :: Text -> Set a -> Text
renderR Text
e Set a
us =
let n :: Int
n = Set a -> Int
forall a. Set a -> Int
Set.size Set a
us
in if | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
| Bool
otherwise -> Text
""
reactionMsg :: Text
reactionMsg = (Text -> Set UserId -> Text) -> Map Text (Set UserId) -> Text
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey Text -> Set UserId -> Text
forall a. Text -> Set a -> Text
renderR (Message
msgMessage
-> Getting (Map Text (Set UserId)) Message (Map Text (Set UserId))
-> Map Text (Set UserId)
forall s a. s -> Getting a s a -> a
^.Getting (Map Text (Set UserId)) Message (Map Text (Set UserId))
Lens' Message (Map Text (Set UserId))
mReactions)
in Widget n -> Maybe (Widget n)
forall a. a -> Maybe a
Just (Widget n -> Maybe (Widget n)) -> Widget n -> Maybe (Widget n)
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
emojiAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reactionMsg)
withParent :: Widget Name -> Widget Name
withParent Widget Name
p =
case ThreadState
mdThreadState of
ThreadState
NoThread -> Widget Name
msgWidget
ThreadState
InThreadShowParent -> Widget Name
p Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<=> Widget Name
replyIndent
ThreadState
InThread -> Widget Name
replyIndent
in if Bool -> Bool
not Bool
mdRenderReplyParent
then Widget Name
msgWidget
else case Message
msgMessage -> Getting ReplyState Message ReplyState -> ReplyState
forall s a. s -> Getting a s a -> a
^.Getting ReplyState Message ReplyState
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 (String -> Widget Name
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 = Maybe Message
forall a. Maybe a
Nothing
, mdRenderReplyParent :: Bool
mdRenderReplyParent = Bool
False
, mdIndentBlocks :: Bool
mdIndentBlocks = Bool
False
}
in Widget Name -> Widget Name
withParent (Widget Name -> Widget Name
forall a. Widget a -> Widget a
addEllipsis (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
forceAttr AttrName
replyParentAttr Widget Name
parentMsg)
where
layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq Block
-> ViewL Block -> Widget Name
layout :: HighlightSet
-> Maybe Int
-> [Widget Name]
-> Seq Block
-> ViewL Block
-> Widget Name
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs ViewL Block
xs | ViewL Block -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ViewL Block
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (Blockquote {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (CodeBlock {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (HTMLBlock {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (List {} :< Seq Block
_) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs (Para Inlines
inlns :< Seq Block
_)
| (Inline -> Bool) -> Seq Inline -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.any Inline -> Bool
breakCheck (Inlines -> Seq Inline
unInlines Inlines
inlns) = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
layout HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs ViewL Block
_ = HighlightSet
-> Maybe Int -> [Widget Name] -> Seq Block -> Widget Name
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
nameNextToMessage HighlightSet
hs Maybe Int
w [Widget Name]
nameElems Seq Block
bs
multiLnLayout :: HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
multiLnLayout HighlightSet
hs Maybe Int
w [Widget n]
nameElems Seq Block
bs =
if Bool
mdIndentBlocks
then [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox [ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
hBox [Widget n]
nameElems
, [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
hBox [Text -> Widget n
forall n. Text -> Widget n
txt Text
" ", Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget n
forall a.
Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
renderRichText Text
mdMyUsername HighlightSet
hs ((Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
2) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
w)
Bool
mdWrapNonhighlightedCodeBlocks (Seq Block -> Blocks
Blocks Seq Block
bs)]
]
else HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
forall n.
HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
nameNextToMessage HighlightSet
hs Maybe Int
w [Widget n]
nameElems Seq Block
bs
nameNextToMessage :: HighlightSet -> Maybe Int -> [Widget n] -> Seq Block -> Widget n
nameNextToMessage HighlightSet
hs Maybe Int
w [Widget n]
nameElems Seq Block
bs =
Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
Result n
nameResult <- Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
hBox [Widget n]
nameElems
let newW :: Maybe Int
newW = Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract (Image -> Int
V.imageWidth (Result n
nameResultResult n -> Getting Image (Result n) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result n) Image
forall n. Lens' (Result n) Image
imageL)) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
w
Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
hBox [ Image -> Widget n
forall n. Image -> Widget n
raw (Result n
nameResultResult n -> Getting Image (Result n) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result n) Image
forall n. Lens' (Result n) Image
imageL)
, Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget n
forall a.
Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
renderRichText Text
mdMyUsername HighlightSet
hs Maybe Int
newW Bool
mdWrapNonhighlightedCodeBlocks (Seq Block -> Blocks
Blocks Seq Block
bs)
]
breakCheck :: Inline -> Bool
breakCheck Inline
i = Inline
i Inline -> [Inline] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Inline
ELineBreak, Inline
ESoftBreak]
addEditSentinel :: Inline -> Blocks -> Blocks
addEditSentinel :: Inline -> Blocks -> Blocks
addEditSentinel Inline
d (Blocks Seq Block
bs) =
case Seq Block -> ViewR Block
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 Blocks -> Blocks -> Blocks
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 (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Seq Inline
forall a. a -> Seq a
S.singleton Inline
sentinel)
in Seq Block -> Blocks
Blocks (Seq Block -> Blocks) -> Seq Block -> Blocks
forall a b. (a -> b) -> a -> b
$ case Block
b of
Para Inlines
is -> Block -> Seq Block
forall a. a -> Seq a
S.singleton (Block -> Seq Block) -> Block -> Seq Block
forall a b. (a -> b) -> a -> b
$ Inlines -> Block
Para (Seq Inline -> Inlines
Inlines (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
unInlines Inlines
is Seq Inline -> Inline -> Seq Inline
forall a. Seq a -> a -> Seq a
|> Inline
ESpace Seq Inline -> Inline -> Seq Inline
forall a. Seq a -> a -> Seq a
|> Inline
sentinel)
Block
_ -> [Block] -> Seq 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 :: Widget a -> Widget a
addEllipsis Widget a
w = Size -> Size -> RenderM a (Result a) -> Widget a
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget (Widget a -> Size
forall n. Widget n -> Size
hSize Widget a
w) (Widget a -> Size
forall n. Widget n -> Size
vSize Widget a
w) (RenderM a (Result a) -> Widget a)
-> RenderM a (Result a) -> Widget a
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- RenderM a Context
forall n. RenderM n Context
getContext
let aw :: Int
aw = Context
ctxContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
availWidthL
Result a
result <- Widget a -> RenderM a (Result a)
forall n. Widget n -> RenderM n (Result n)
render Widget a
w
let withEllipsis :: Widget a
withEllipsis = (Int -> Widget a -> Widget a
forall n. Int -> Widget n -> Widget n
hLimit (Int
aw Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Int -> Widget a -> Widget a
forall n. Int -> Widget n -> Widget n
vLimit Int
1 (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ (Size -> Size -> RenderM a (Result a) -> Widget a
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM a (Result a) -> Widget a)
-> RenderM a (Result a) -> Widget a
forall a b. (a -> b) -> a -> b
$ Result a -> RenderM a (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
result)) Widget a -> Widget a -> Widget a
forall n. Widget n -> Widget n -> Widget n
<+>
String -> Widget a
forall n. String -> Widget n
str String
"..."
if (Image -> Int
V.imageHeight (Result a
resultResult a -> Getting Image (Result a) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result a) Image
forall n. Lens' (Result n) Image
imageL) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Bool -> Bool -> Bool
|| (Image -> Int
V.imageWidth (Result a
resultResult a -> Getting Image (Result a) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result a) Image
forall n. Lens' (Result n) Image
imageL) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
aw) then
Widget a -> RenderM a (Result a)
forall n. Widget n -> RenderM n (Result n)
render Widget a
withEllipsis else
Result a -> RenderM a (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
result