{-# 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

-- | A bundled structure that includes all the information necessary
-- to render a given message
data MessageData =
    MessageData { MessageData -> Maybe ServerTime
mdEditThreshold :: Maybe ServerTime
                -- ^ If specified, any messages edited before this point
                -- in time are not indicated as edited.
                , MessageData -> Bool
mdShowOlderEdits :: Bool
                -- ^ Indicates whether "edited" markers should be shown
                -- for old messages (i.e., ignore the mdEditThreshold
                -- value).
                , MessageData -> Bool
mdShowReactions :: Bool
                -- ^ Whether to render reactions.
                , MessageData -> Message
mdMessage :: Message
                -- ^ The message to render.
                , MessageData -> Maybe Text
mdUserName :: Maybe Text
                -- ^ The username of the message's author, if any. This
                -- is passed here rather than obtaining from the message
                -- because we need to do lookups in the ChatState to
                -- compute this, and we don't pass the ChatState into
                -- renderMessage.
                , MessageData -> Maybe Message
mdParentMessage :: Maybe Message
                -- ^ The parent message of this message, if any.
                , MessageData -> Maybe Text
mdParentUserName :: Maybe Text
                -- ^ The author of the parent message, if any.
                , MessageData -> ThreadState
mdThreadState :: ThreadState
                -- ^ The thread state of this message.
                , MessageData -> Bool
mdRenderReplyParent :: Bool
                -- ^ Whether to render the parent message.
                , MessageData -> Bool
mdRenderReplyIndent :: Bool
                -- ^ Whether to render reply indent decorations
                , MessageData -> HighlightSet
mdHighlightSet :: HighlightSet
                -- ^ The highlight set to use to highlight usernames,
                -- channel names, etc.
                , MessageData -> Bool
mdIndentBlocks :: Bool
                -- ^ Whether to indent the message underneath the
                -- author's name (True) or just display it to the right
                -- of the author's name (False).
                , MessageData -> Maybe Int
mdTruncateVerbatimBlocks :: Maybe Int
                -- ^ At what height to truncate long verbatim/code blocks.
                , MessageData -> Maybe Int
mdMessageWidthLimit :: Maybe Int
                -- ^ A width override to use to wrap non-code blocks
                -- and code blocks without syntax highlighting. If
                -- unspecified, all blocks in the message will be
                -- wrapped and truncated at the width specified by the
                -- rendering context. If specified, all non-code blocks
                -- will be wrapped at this width and highlighted code
                -- blocks will be rendered using the context's width.
                , MessageData -> Text
mdMyUsername :: Text
                -- ^ The username of the user running Matterhorn.
                , MessageData -> UserId
mdMyUserId :: UserId
                -- ^ The user ID of the user running Matterhorn.
                , MessageData -> Bool
mdWrapNonhighlightedCodeBlocks :: Bool
                -- ^ Whether to wrap text in non-highlighted code
                -- blocks.
                , MessageData -> Name
mdClickableNameTag :: Name
                -- ^ Used to namespace clickable extents produced by
                -- rendering this message
                }

maxMessageHeight :: Int
maxMessageHeight :: Int
maxMessageHeight = Int
200

botUserLabel :: T.Text
botUserLabel :: Text
botUserLabel = Text
"[BOT]"

pinIndicator :: T.Text
pinIndicator :: Text
pinIndicator = Text
"[PIN]"

-- | printableNameForUserRef converts the UserRef into a printable name,
-- based on the current known user data.
printableNameForUserRef :: ChatState -> UserRef -> Maybe Text
printableNameForUserRef :: ChatState -> UserRef -> Maybe Text
printableNameForUserRef 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 is the main message drawing function.
renderSingleMessage :: ChatState
                    -- ^ The application state
                    -> HighlightSet
                    -- ^ The highlight set to use when rendering this
                    -- message
                    -> Bool
                    -- ^ Whether to render reply indentations
                    -> Maybe ServerTime
                    -- ^ This specifies an "indicator boundary". Showing
                    -- various indicators (e.g. "edited") is not
                    -- typically done for messages that are older than
                    -- this boundary value.
                    -> Message
                    -- ^ The message to render
                    -> ThreadState
                    -- ^ The thread state in which to render the message
                    -> Name
                    -- ^ Clickable name tag
                    -> 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
                    (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)
                    Bool
renderReplyIndent Message
m

renderChatMessage :: ChatState
                  -- ^ The application state
                  -> HighlightSet
                  -- ^ The highlight set to use when rendering this
                  -- message
                  -> Maybe ServerTime
                  -- ^ This specifies an "indicator boundary". Showing
                  -- various indicators (e.g. "edited") is not typically
                  -- done for messages that are older than this boundary
                  -- value.
                  -> ThreadState
                  -- ^ The thread state in which to render the message
                  -> Name
                  -- ^ The UI region in which the message is being
                  -- rendered (for tagging clickable extents)
                  -> (ServerTime -> Widget Name)
                  -- ^ A function to render server times
                  -> Bool
                  -- ^ Whether to render reply indentations
                  -> Message
                  -- ^ The message to render
                  -> 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
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
-> Bool
-> HighlightSet
-> Bool
-> Maybe Int
-> Maybe Int
-> Text
-> UserId
-> Bool
-> Name
-> 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
printableNameForUserRef 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
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 = 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
              , mdMyUserId :: UserId
mdMyUserId          = User -> UserId
userId (User -> UserId) -> User -> UserId
forall a b. (a -> b) -> a -> b
$ ChatState -> User
myUser ChatState
st
              , mdWrapNonhighlightedCodeBlocks :: Bool
mdWrapNonhighlightedCodeBlocks = Bool
True
              , mdTruncateVerbatimBlocks :: Maybe Int
mdTruncateVerbatimBlocks = ChatState
stChatState -> Getting (Maybe Int) ChatState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) ChatState (Maybe Int)
Lens' ChatState (Maybe Int)
csVerbatimTruncateSetting
              , mdClickableNameTag :: Name
mdClickableNameTag  = Name
clickableNameTag
              }
        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

-- | Render a selected message with focus, including the messages
-- before and the messages after it. The foldable parameters exist
-- because (depending on the situation) we might use either of the
-- message list types for the 'before' and 'after' (i.e. the
-- chronological or retrograde message sequences).
unsafeRenderMessageSelection :: (SeqDirection dir1, SeqDirection dir2)
                             => ( (Message, ThreadState)
                                , ( DirectionalSeq dir1 (Message, ThreadState)
                                  , DirectionalSeq dir2 (Message, ThreadState)
                                  )
                                )
                             -- ^ The message to render, the messages
                             -- before it, and after it, respectively
                             -> (Message -> ThreadState -> Name -> Widget Name)
                             -- ^ A per-message rendering function to
                             -- use
                             -> Name
                             -- ^ Clickable name tag
                             -> Widget Name
unsafeRenderMessageSelection :: ((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 =
  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 Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
    Result Name
curMsgResult <- (Context Name -> Context Name)
-> 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 Name -> Context Name
forall n. Context n -> Context n
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 -> Name -> Widget Name
doMsgRender Message
curMsg ThreadState
curThreadState Name
tag

    let targetHeight :: Int
targetHeight = Context Name
ctxContext Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context Name) Int
forall n. Lens' (Context n) 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

    [Result Name]
lowerHalfResults <- Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir2 (Message, ThreadState)
-> RenderM Name [Result Name]
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) Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
vLimit Name
tag DirectionalSeq dir2 (Message, ThreadState)
after
    [Result Name]
upperHalfResults <- Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir1 (Message, ThreadState)
-> RenderM Name [Result Name]
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) Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
cropTopTo Name
tag DirectionalSeq dir1 (Message, ThreadState)
before

    let upperHalfResultsHeight :: Int
upperHalfResultsHeight = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Image -> Int
V.imageHeight (Image -> Int) -> (Result Name -> Image) -> Result Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result Name -> Image
forall n. Result n -> Image
image) (Result Name -> Int) -> [Result Name] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Result Name]
upperHalfResults
        lowerHalfResultsHeight :: Int
lowerHalfResultsHeight = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Image -> Int
V.imageHeight (Image -> Int) -> (Result Name -> Image) -> Result Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result Name -> Image
forall n. Result n -> Image
image) (Result Name -> Int) -> [Result Name] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Result Name]
lowerHalfResults
        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 :: Widget Name
uncropped = [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
$ (Result Name -> Widget Name) -> [Result Name] -> [Widget Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget ([Result Name] -> [Widget Name]) -> [Result Name] -> [Widget Name]
forall a b. (a -> b) -> a -> b
$
                           ([Result Name] -> [Result Name]
forall a. [a] -> [a]
reverse [Result Name]
upperHalfResults) [Result Name] -> [Result Name] -> [Result Name]
forall a. Semigroup a => a -> a -> a
<> (Result Name
curMsgResult Result Name -> [Result Name] -> [Result Name]
forall a. a -> [a] -> [a]
: [Result Name]
lowerHalfResults)

        cropTop :: Int -> Widget n -> Widget n
cropTop Int
h Widget n
w = 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
result <- (Context n -> Context n)
-> RenderM n (Result n) -> RenderM n (Result n)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT Context n -> Context n
forall n. Context n -> Context n
relaxHeight (RenderM n (Result n) -> RenderM n (Result n))
-> RenderM n (Result n) -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render Widget n
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
$ Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
cropTopTo Int
h (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Result n -> Widget n
forall n. Result n -> Widget n
resultToWidget Result n
result
        cropBottom :: Int -> Widget n -> Widget n
cropBottom Int
h Widget n
w = 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
result <- (Context n -> Context n)
-> RenderM n (Result n) -> RenderM n (Result n)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT Context n -> Context n
forall n. Context n -> Context n
relaxHeight (RenderM n (Result n) -> RenderM n (Result n))
-> RenderM n (Result n) -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render Widget n
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
$ Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
cropBottomTo Int
h (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Result n -> Widget n
forall n. Result n -> Widget n
resultToWidget Result n
result

        lowerHalf :: Widget Name
lowerHalf = [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
$ (Result Name -> Widget Name) -> [Result Name] -> [Widget Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget [Result Name]
lowerHalfResults
        upperHalf :: Widget Name
upperHalf = [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
$ (Result Name -> Widget Name) -> [Result Name] -> [Widget Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget ([Result Name] -> [Widget Name]) -> [Result Name] -> [Widget Name]
forall a b. (a -> b) -> a -> b
$ [Result Name] -> [Result Name]
forall a. [a] -> [a]
reverse [Result Name]
upperHalfResults

    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
$ if | Int
lowerHalfResultsHeight 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 -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
cropTop Int
targetHeight Widget Name
uncropped
                | Int
upperHalfResultsHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
upperHeight ->
                    Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
vLimit Int
targetHeight Widget Name
uncropped
                | Bool
otherwise ->
                    Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
cropTop Int
upperHeight Widget Name
upperHalf Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<=> (Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget Result Name
curMsgResult) Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<=>
                       (if Int
curHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lowerHeight
                         then Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
cropBottom (Int
lowerHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curHeight) Widget Name
lowerHalf
                         else Int -> Widget Name -> Widget Name
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 :: 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
    | DirectionalSeq dir (Message, ThreadState) -> Int
forall seq a. DirectionalSeq seq a -> Int
messagesLength DirectionalSeq dir (Message, ThreadState)
ms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Result Name] -> RenderM Name [Result Name]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
        let (Message
m, ThreadState
threadState) = Maybe (Message, ThreadState) -> (Message, ThreadState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Message, ThreadState) -> (Message, ThreadState))
-> Maybe (Message, ThreadState) -> (Message, ThreadState)
forall a b. (a -> b) -> a -> b
$ DirectionalSeq dir (Message, ThreadState)
-> Maybe (Message, ThreadState)
forall seq a. SeqDirection seq => DirectionalSeq seq a -> Maybe a
messagesHead DirectionalSeq dir (Message, ThreadState)
ms
            maybeCache :: Widget Name -> Widget Name
maybeCache = case Message
mMessage
-> Getting (Maybe MessageId) Message (Maybe MessageId)
-> Maybe MessageId
forall s a. s -> Getting a s a -> a
^.Getting (Maybe MessageId) Message (Maybe MessageId)
Lens' Message (Maybe MessageId)
mMessageId of
                Maybe MessageId
Nothing -> Widget Name -> Widget Name
forall a. a -> a
id
                Just MessageId
i -> Name -> Widget Name -> Widget Name
forall n. Ord n => n -> Widget n -> Widget n
cached (MessageId -> Name
RenderedMessage MessageId
i)
        Result Name
result <- 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
limitFunc Int
remainingHeight (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Widget Name -> Widget Name
maybeCache (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Message -> ThreadState -> Name -> Widget Name
renderFunc Message
m ThreadState
threadState Name
tag
        [Result Name]
rest <- Int
-> (Message -> ThreadState -> Name -> Widget Name)
-> (Int -> Widget Name -> Widget Name)
-> Name
-> DirectionalSeq dir (Message, ThreadState)
-> RenderM Name [Result Name]
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Image -> Int
V.imageHeight (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result Name
resultResult 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)) Message -> ThreadState -> Name -> Widget Name
renderFunc Int -> Widget Name -> Widget Name
limitFunc Name
tag (Int
-> DirectionalSeq dir (Message, ThreadState)
-> DirectionalSeq dir (Message, ThreadState)
forall seq a.
SeqDirection seq =>
Int -> DirectionalSeq seq a -> DirectionalSeq seq a
messagesDrop Int
1 DirectionalSeq dir (Message, ThreadState)
ms)
        [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
result Result Name -> [Result Name] -> [Result Name]
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 =
    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 Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
        let targetHeight :: Int
targetHeight = Context Name
ctxContext Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context Name) Int
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 = ((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 :: 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 | 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 = [Result Name] -> RenderM Name [Result Name]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            go Int
remainingHeight DirectionalSeq Retrograde (Message, ThreadState)
ms = do
                let (Message
m, ThreadState
threadState) = Maybe (Message, ThreadState) -> (Message, ThreadState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Message, ThreadState) -> (Message, ThreadState))
-> Maybe (Message, ThreadState) -> (Message, ThreadState)
forall a b. (a -> b) -> a -> b
$ 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

                Result Name
result <- 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
$ (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 <- 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
cropTopTo Int
remainingHeight (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget Result Name
result

                -- If the new message fills the window, check whether
                -- there is still a "New Messages" transition that is
                -- not displayed. If there is, then we need to replace
                -- the top line of the new image with a "New Messages"
                -- indicator.
                if Image -> Int
V.imageHeight (Result Name
resultResult 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 -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
remainingHeight
                then do
                    Result Name
single <- if Bool
newMessagesAbove
                              then do
                                  Result Name
result' <- 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
$
                                      [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox [ 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 ↑")
                                           , Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
cropTopBy Int
1 (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget Result Name
croppedResult
                                           ]
                                  Result Name -> RenderM Name (Result Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Result Name
result'
                              else do
                                  Result Name -> RenderM Name (Result Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Result Name
croppedResult
                    [Result Name] -> RenderM Name [Result Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Result Name
single]
                else do
                    let unusedHeight :: Int
unusedHeight = Int
remainingHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Image -> Int
V.imageHeight (Result Name
resultResult 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)
                    [Result Name]
rest <- Int
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name [Result Name]
go Int
unusedHeight (DirectionalSeq Retrograde (Message, ThreadState)
 -> RenderM Name [Result Name])
-> DirectionalSeq Retrograde (Message, ThreadState)
-> RenderM Name [Result Name]
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
                    [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
result Result Name -> [Result Name] -> [Result Name]
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
        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
$ [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
$ Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget (Result Name -> Widget Name) -> [Result Name] -> [Widget Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Result Name] -> [Result Name]
forall a. [a] -> [a]
reverse [Result Name]
results

relaxHeight :: Context n -> Context n
relaxHeight :: Context n -> Context n
relaxHeight Context n
c = Context n
c Context n -> (Context n -> Context n) -> Context n
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Context n -> Identity (Context n)
forall n. Lens' (Context n) Int
availHeightL ((Int -> Identity Int) -> Context n -> Identity (Context n))
-> Int -> Context n -> Context n
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 n
cContext n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context n) Int
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
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 -> Widget Name
forall n. Widget n
emptyWidget
    Bool
False ->
        Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
            (Context Name -> Context Name)
-> 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 Name -> Context Name
forall n. Context n -> Context n
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 -> Name -> Widget Name
doMsgRender Message
msg ThreadState
threadState Name
tag

-- | This performs rendering of the specified message according to
-- settings in MessageData.
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
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

        botAuthorElem :: Widget n
botAuthorElem = if Message -> Bool
isBotMessage Message
msg
                        then Text -> Widget n
forall n. Text -> Widget n
txt Text
botUserLabel
                        else Widget n
forall n. Widget n
emptyWidget

        mId :: Maybe MessageId
mId = Message
msgMessage
-> Getting (Maybe MessageId) Message (Maybe MessageId)
-> Maybe MessageId
forall s a. s -> Getting a s a -> a
^.Getting (Maybe MessageId) Message (Maybe MessageId)
Lens' Message (Maybe MessageId)
mMessageId

        clickableAuthor :: Text -> Widget Name -> Widget Name
clickableAuthor Text
un = case Maybe MessageId
mId of
            Maybe MessageId
Nothing -> Widget Name -> Widget Name
forall a. a -> a
id
            -- We use the index (-1) since indexes for clickable
            -- usernames elsewhere in this message start at 0.
            Just MessageId
i -> Name -> Widget Name -> Widget Name
forall n. Ord n => n -> Widget n -> Widget n
clickable (Maybe MessageId -> Name -> Int -> Text -> Name
ClickableUsername (MessageId -> Maybe MessageId
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 ->
                [ AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
pinnedMessageIndicatorAttr (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Widget Name
forall n. Text -> Widget n
txt (Text -> Widget Name) -> Text -> Widget Name
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
pinIndicator else Text
""
                , Text -> Widget Name
forall n. Text -> Widget n
txt (Text -> Widget Name) -> Text -> Widget Name
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 -> Widget Name -> Widget Name
clickableAuthor Text
un (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Widget Name
forall a. Text -> Text -> Text -> Widget a
colorUsername Text
mdMyUsername Text
un Text
un
                , Widget Name
forall n. Widget n
botAuthorElem
                , Text -> Widget Name
forall n. Text -> Widget n
txt Text
" "
                ]
            | Bool
otherwise ->
                [ AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
pinnedMessageIndicatorAttr (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Widget Name
forall n. Text -> Widget n
txt (Text -> Widget Name) -> Text -> Widget Name
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
pinIndicator Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " else Text
""
                , Text -> Widget Name -> Widget Name
clickableAuthor Text
un (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Widget Name
forall a. Text -> Text -> Text -> Widget a
colorUsername Text
mdMyUsername Text
un Text
un
                , Widget Name
forall n. Widget n
botAuthorElem
                , Text -> Widget Name
forall n. Text -> Widget n
txt (Text -> Widget Name) -> Text -> Widget Name
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 -> []

        -- Use the editing threshold to determine whether to append an
        -- editing indication to this message.
        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
renderBlocks HighlightSet
mdHighlightSet Maybe Int
mdMessageWidthLimit [Widget Name]
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)
msgAtch, MessageData -> Maybe (Widget Name)
messageReactions MessageData
md]

        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 Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
            Widget Name
w <- case Bool
mdRenderReplyIndent of
                Bool
True -> do
                    -- NB: The amount subtracted here must be the total
                    -- padding added below (pad 1 + vBorder)
                    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 Name
ctxContext Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context Name) Int
forall n. Lens' (Context n) Int
availWidthL Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Widget Name
msgWidget
                    Widget Name
-> ReaderT (Context Name) (State (RenderState Name)) (Widget Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget Name
 -> ReaderT (Context Name) (State (RenderState Name)) (Widget Name))
-> Widget Name
-> ReaderT (Context Name) (State (RenderState Name)) (Widget 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
<+> Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget Result Name
w
                Bool
False ->
                    Widget Name
-> ReaderT (Context Name) (State (RenderState Name)) (Widget Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Widget Name
msgWidget
            Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render Widget Name
w

        msgAtch :: Maybe (Widget Name)
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 Name)
forall a. Maybe a
Nothing
          else Widget Name -> Maybe (Widget Name)
forall a. a -> Maybe a
Just (Widget Name -> Maybe (Widget Name))
-> Widget Name -> Maybe (Widget Name)
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox
                 [ Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padLeft (Int -> Padding
Pad Int
2) (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Name -> Widget Name -> Widget Name
forall n. Ord n => n -> Widget n -> Widget n
clickable (Name -> FileId -> Name
ClickableAttachmentInMessage Name
mdClickableNameTag (Attachment
aAttachment -> Getting FileId Attachment FileId -> FileId
forall s a. s -> Getting a s a -> a
^.Getting FileId Attachment FileId
Lens' Attachment FileId
attachmentFileId)) (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
                                     Text -> Widget Name
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)
                 ]

        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 Widget Name -> Widget Name
forall a. Widget a -> Widget a
freezeBorders (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
       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
        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 | 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
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
_)
            | (Inline -> Bool) -> Seq Inline -> Bool
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 [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox [ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox [Widget Name]
nameElems
                         , [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox [Text -> Widget Name
forall n. Text -> Widget n
txt Text
"  ", Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe Name)
-> Blocks
-> Widget Name
forall a.
SemEq a =>
Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> 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
                                                 Maybe Int
mdTruncateVerbatimBlocks
                                                 ((Int -> Inline -> Maybe Name)
-> Maybe (Int -> Inline -> Maybe Name)
forall a. a -> Maybe a
Just (Maybe MessageId -> Name -> Int -> Inline -> Maybe Name
mkClickableInline (Message
msgMessage
-> Getting (Maybe MessageId) Message (Maybe MessageId)
-> Maybe MessageId
forall s a. s -> Getting a s a -> a
^.Getting (Maybe MessageId) Message (Maybe MessageId)
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 =
            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
                Result Name
nameResult <- 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
$ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox [Widget Name]
nameElems
                let newW :: Maybe Int
newW = Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract (Image -> Int
V.imageWidth (Result Name
nameResultResult 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 -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
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
$ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox [ Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget Result Name
nameResult
                              , Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe Name)
-> Blocks
-> Widget Name
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
                                  ((Int -> Inline -> Maybe Name)
-> Maybe (Int -> Inline -> Maybe Name)
forall a. a -> Maybe a
Just (Maybe MessageId -> Name -> Int -> Inline -> Maybe Name
mkClickableInline (Message
msgMessage
-> Getting (Maybe MessageId) Message (Maybe MessageId)
-> Maybe MessageId
forall s a. s -> Getting a s a -> a
^.Getting (Maybe MessageId) Message (Maybe MessageId)
Lens' Message (Maybe MessageId)
mMessageId) Name
mdClickableNameTag)) (Seq Block -> Blocks
Blocks Seq Block
bs)
                              ]

        isBreak :: Inline -> Bool
isBreak Inline
i = Inline
i Inline -> [Inline] -> Bool
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
    Name -> Maybe Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Maybe MessageId -> Name -> Int -> LinkTarget -> Name
ClickableURL Maybe MessageId
mmId Name
scope Int
i (LinkTarget -> Name) -> LinkTarget -> Name
forall a b. (a -> b) -> a -> b
$ URL -> LinkTarget
LinkURL URL
u
mkClickableInline Maybe MessageId
mmId Name
scope Int
i (EUser Text
name) =
    Name -> Maybe Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name) -> Name -> Maybe Name
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
_) =
    Name -> Maybe Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Maybe MessageId -> Name -> Int -> LinkTarget -> Name
ClickableURL Maybe MessageId
mmId Name
scope Int
i (LinkTarget -> Name) -> LinkTarget -> Name
forall a b. (a -> b) -> a -> b
$ TeamURLName -> PostId -> LinkTarget
LinkPermalink TeamURLName
teamUrlName PostId
pId
mkClickableInline Maybe MessageId
_ Name
_ Int
_ Inline
_ =
    Maybe Name
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 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 Name)
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 = Set UserId -> Int
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 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
"]"
                                  | Bool
otherwise -> 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
"]"
                     w :: Widget Name
w = Bool -> Text -> Set UserId -> Text -> Widget Name
makeReactionWidget Bool
mine Text
e Set UserId
us Text
content
                 in Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) Widget Name
w Widget Name -> [Widget Name] -> [Widget Name]
forall a. a -> [a] -> [a]
: [Widget Name]
lst
             nonEmptyReactions :: Map Text (Set UserId)
nonEmptyReactions = (Set UserId -> Bool)
-> Map Text (Set UserId) -> Map Text (Set UserId)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Set UserId -> Bool) -> Set UserId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set UserId -> Bool
forall a. Set a -> Bool
Set.null) (Map Text (Set UserId) -> Map Text (Set UserId))
-> Map Text (Set UserId) -> Map Text (Set UserId)
forall a b. (a -> b) -> a -> b
$ 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
             isMyReaction :: Set UserId -> Bool
isMyReaction = UserId -> Set UserId -> Bool
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 = AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
attr (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
t
                     attr :: AttrName
attr = if Bool
mine then AttrName
myReactionAttr else AttrName
reactionAttr
                 in Widget Name -> (Name -> Widget Name) -> Maybe Name -> Widget Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Widget Name
forall n. Widget n
w ((Name -> Widget Name -> Widget Name)
-> Widget Name -> Name -> Widget Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Widget Name -> Widget Name
forall n. Ord n => n -> Widget n -> Widget n
clickable Widget Name
forall n. Widget n
w) (Maybe Name -> Widget Name) -> Maybe Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Set UserId -> Maybe Name
makeName Text
e Set UserId
us
             hasAnyReactions :: Bool
hasAnyReactions = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Text (Set UserId) -> Bool
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 (Post -> PostId) -> Maybe Post -> Maybe PostId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
                 Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
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 = 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 Name
ctx <- RenderM Name (Context Name)
forall n. RenderM n (Context n)
getContext
                 let lineW :: Int
lineW = Context Name
ctxContext Name -> Getting Int (Context Name) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context Name) Int
forall n. Lens' (Context n) Int
availWidthL
                 [Result Name]
reacs <- (Widget Name -> RenderM Name (Result Name))
-> [Widget Name] -> RenderM Name [Result Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
$ (Text -> Set UserId -> [Widget Name] -> [Widget Name])
-> [Widget Name] -> Map Text (Set UserId) -> [Widget Name]
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 :: [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [Result n]
l Int
_ []     = if [Result n] -> Bool
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 (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result n
rResult 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
                         in if Int
rW Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w
                            then [Result n] -> Int -> [Result n] -> [[Result n]]
forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines ([Result n]
l [Result n] -> [Result n] -> [Result n]
forall a. Semigroup a => a -> a -> a
<> [Result n
r]) (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rW) [Result n]
rs
                            else if Int
rW Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineW
                                 then [Result n]
l [Result n] -> [[Result n]] -> [[Result n]]
forall a. a -> [a] -> [a]
: [Result n
r] [Result n] -> [[Result n]] -> [[Result n]]
forall a. a -> [a] -> [a]
: [Result n] -> Int -> [Result n] -> [[Result n]]
forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [] Int
lineW [Result n]
rs
                                 else [Result n]
l [Result n] -> [[Result n]] -> [[Result n]]
forall a. a -> [a] -> [a]
: [Result n] -> Int -> [Result n] -> [[Result n]]
forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [] Int
lineW (Result n
rResult n -> [Result n] -> [Result n]
forall a. a -> [a] -> [a]
:[Result n]
rs)

                 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
$ [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
$ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
hBox ([Widget Name] -> Widget Name) -> [[Widget Name]] -> [Widget Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Result Name] -> [Widget Name])
-> [[Result Name]] -> [[Widget Name]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Result Name -> Widget Name) -> [Result Name] -> [Widget Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget)) ([Result Name] -> Int -> [Result Name] -> [[Result Name]]
forall n. [Result n] -> Int -> [Result n] -> [[Result n]]
reacLines [] Int
lineW [Result Name]
reacs)
         in if Bool
hasAnyReactions
            then Widget Name -> Maybe (Widget Name)
forall a. a -> Maybe a
Just (Widget Name -> Maybe (Widget Name))
-> Widget Name -> Maybe (Widget Name)
forall a b. (a -> b) -> a -> b
$ Text -> Widget Name
forall n. Text -> Widget n
txt Text
"   " Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<+> Widget Name
reactionWidget
            else Maybe (Widget Name)
forall a. Maybe a
Nothing

-- Add the edit sentinel to the end of the last block in the sequence.
-- If the last block is a paragraph, append it to that paragraph.
-- Otherwise, append a new block so it appears beneath the last
-- block-level element.
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 a
ctx <- RenderM a (Context a)
forall n. RenderM n (Context n)
getContext
    let aw :: Int
aw = Context a
ctxContext a -> Getting Int (Context a) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context a) Int
forall n. Lens' (Context n) 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
$ (Result a -> Widget a
forall n. Result n -> Widget n
resultToWidget 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