{-# LANGUAGE RankNTypes #-}
module Matterhorn.Draw.MessageInterface
( drawMessageInterface
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick
import Brick.Keybindings
import Brick.Focus ( withFocusRing )
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List ( listElements, listSelectedElement, renderList )
import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents )
import Data.Char ( isSpace, isPunctuation )
import qualified Data.Foldable as F
import Data.List ( intersperse )
import Data.Maybe ( fromJust )
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Zipper ( cursorPosition )
import Data.Time.Clock ( UTCTime(..) )
import Lens.Micro.Platform ( (.~), (^?!), to, view, Lens', Traversal', SimpleGetter )
import Network.Mattermost.Types ( ChannelId, Type(Direct, Group)
, ServerTime(..), TeamId, idString
)
import Matterhorn.Constants
import Matterhorn.Draw.Buttons
import Matterhorn.Draw.Messages
import Matterhorn.Draw.ManageAttachments
import Matterhorn.Draw.InputPreview
import Matterhorn.Draw.Util
import Matterhorn.Draw.RichText
import Matterhorn.Events.MessageSelect
import Matterhorn.Events.UrlSelect
import Matterhorn.State.MessageSelect
import Matterhorn.Themes
import Matterhorn.TimeUtils ( justAfter, justBefore )
import Matterhorn.Types
import Matterhorn.Types.DirectionalSeq ( emptyDirSeq )
import Matterhorn.Types.RichText
drawMessageInterface :: ChatState
-> HighlightSet
-> TeamId
-> Bool
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Bool
-> Widget Name
drawMessageInterface :: forall i.
ChatState
-> HighlightSet
-> TeamId
-> Bool
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Bool
-> Widget Name
drawMessageInterface ChatState
st HighlightSet
hs TeamId
tId Bool
showNewMsgLine Lens' ChatState (MessageInterface Name i)
which Bool
renderReplyIndent Bool
focused =
Widget Name
interfaceContents
where
inMsgSelect :: Bool
inMsgSelect = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) MessageInterfaceMode
miMode forall a. Eq a => a -> a -> Bool
== MessageInterfaceMode
MessageSelect
eName :: Name
eName = forall a n. Named a n => a -> n
getName forall a b. (a -> b) -> a -> b
$ ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) (Editor Text n)
esEditor
region :: Name
region = Name -> Name
MessageInterfaceMessages Name
eName
previewVpName :: Name
previewVpName = Name -> Name
MessagePreviewViewport Name
eName
interfaceContents :: Widget Name
interfaceContents =
case ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) MessageInterfaceMode
miMode of
MessageInterfaceMode
Compose -> Bool -> Widget Name
renderMessages Bool
False
MessageInterfaceMode
MessageSelect -> Bool -> Widget Name
renderMessages Bool
True
MessageInterfaceMode
ShowUrlList -> forall i.
ChatState
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
drawUrlSelectWindow ChatState
st HighlightSet
hs Lens' ChatState (MessageInterface Name i)
which
SaveAttachment {} -> forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
drawSaveAttachmentWindow ChatState
st Lens' ChatState (MessageInterface Name i)
which
MessageInterfaceMode
ManageAttachments -> forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
drawAttachmentList ChatState
st Lens' ChatState (MessageInterface Name i)
which
MessageInterfaceMode
BrowseFiles -> forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
drawFileBrowser ChatState
st Lens' ChatState (MessageInterface Name i)
which
renderMessages :: Bool -> Widget Name
renderMessages Bool
inMsgSel =
forall n. [Widget n] -> Widget n
vBox [ forall n. Widget n -> Widget n
freezeBorders forall a b. (a -> b) -> a -> b
$
forall i.
ChatState
-> Bool
-> Bool
-> TeamId
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Name
-> Widget Name
renderMessageListing ChatState
st Bool
inMsgSel Bool
showNewMsgLine TeamId
tId HighlightSet
hs Lens' ChatState (MessageInterface Name i)
which Bool
renderReplyIndent Name
region
, Widget Name
bottomBorder
, ChatState
-> SimpleGetter ChatState (EditState Name)
-> TeamId
-> Name
-> HighlightSet
-> Widget Name
inputPreview ChatState
st (Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditor) TeamId
tId Name
previewVpName HighlightSet
hs
, ChatState
-> Lens' ChatState (EditState Name)
-> Bool
-> HighlightSet
-> Widget Name
inputArea ChatState
st (Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditor) Bool
focused HighlightSet
hs
]
bottomBorder :: Widget Name
bottomBorder =
if Bool
inMsgSelect
then forall i.
ChatState
-> TeamId
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
messageSelectBottomBar ChatState
st TeamId
tId Lens' ChatState (MessageInterface Name i)
which
else forall n. [Widget n] -> Widget n
hBox [ forall {n}. Widget n
showAttachmentCount
, forall {n}. Widget n
hBorder
, Widget Name
showTypingUsers
, forall {n}. Widget n
showBusy
]
showBusy :: Widget n
showBusy = case ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (Maybe (Maybe Int))
csWorkerIsBusy of
Just (Just Int
n) -> forall n. Int -> Widget n -> Widget n
hLimit Int
2 forall {n}. Widget n
hBorder forall n. Widget n -> Widget n -> Widget n
<+> forall n. Text -> Widget n
txt (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"*" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n)
Just Maybe Int
Nothing -> forall n. Int -> Widget n -> Widget n
hLimit Int
2 forall {n}. Widget n
hBorder forall n. Widget n -> Widget n -> Widget n
<+> forall n. Text -> Widget n
txt Text
"*"
Maybe (Maybe Int)
Nothing -> forall {n}. Widget n
emptyWidget
showTypingUsers :: Widget Name
showTypingUsers =
let format :: Text -> Widget Name
format = forall a.
SemEq a =>
Maybe TeamBaseURL
-> Text
-> HighlightSet
-> Maybe (Int -> Inline -> Maybe a)
-> Text
-> Widget a
renderText' forall a. Maybe a
Nothing (ChatState -> Text
myUsername ChatState
st) HighlightSet
hs forall a. Maybe a
Nothing
in case TypingUsers -> [UserId]
allTypingUsers (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EphemeralEditState
esEphemeralforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' EphemeralEditState TypingUsers
eesTypingUsers) of
[] -> forall {n}. Widget n
emptyWidget
[UserId
uId] | Just Text
un <- UserId -> ChatState -> Maybe Text
usernameForUserId UserId
uId ChatState
st ->
Text -> Widget Name
format forall a b. (a -> b) -> a -> b
$ Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addUserSigil Text
un forall a. Semigroup a => a -> a -> a
<> Text
" is typing]"
[UserId
uId1, UserId
uId2] | Just Text
un1 <- UserId -> ChatState -> Maybe Text
usernameForUserId UserId
uId1 ChatState
st
, Just Text
un2 <- UserId -> ChatState -> Maybe Text
usernameForUserId UserId
uId2 ChatState
st ->
Text -> Widget Name
format forall a b. (a -> b) -> a -> b
$ Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addUserSigil Text
un1 forall a. Semigroup a => a -> a -> a
<> Text
" and " forall a. Semigroup a => a -> a -> a
<> Text -> Text
addUserSigil Text
un2 forall a. Semigroup a => a -> a -> a
<> Text
" are typing]"
[UserId]
_ -> Text -> Widget Name
format Text
"[several people are typing]"
kc :: KeyConfig KeyEvent
kc = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config (KeyConfig KeyEvent)
configUserKeysL
showAttachmentCount :: Widget n
showAttachmentCount =
let count :: Int
count = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall n (t :: * -> *) e. GenericList n t e -> t e
listElements forall a b. (a -> b) -> a -> b
$ ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) (List n AttachmentData)
esAttachmentList
in if Int
count forall a. Eq a => a -> a -> Bool
== Int
0
then forall {n}. Widget n
emptyWidget
else forall n. [Widget n] -> Widget n
hBox [ forall n. Int -> Widget n -> Widget n
hLimit Int
1 forall {n}. Widget n
hBorder
, forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientMessageAttr forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ Text
"(" forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
count) forall a. Semigroup a => a -> a -> a
<> Text
" attachment" forall a. Semigroup a => a -> a -> a
<>
(if Int
count forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"" else Text
"s") forall a. Semigroup a => a -> a -> a
<> Text
"; "
, forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ Maybe Binding -> Text
ppMaybeBinding (forall k. (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding
firstActiveBinding KeyConfig KeyEvent
kc KeyEvent
ShowAttachmentListEvent)
, forall n. Text -> Widget n
txt Text
" to manage)"
]
messageSelectBottomBar :: ChatState
-> TeamId
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
messageSelectBottomBar :: forall i.
ChatState
-> TeamId
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
messageSelectBottomBar ChatState
st TeamId
tId Lens' ChatState (MessageInterface Name i)
which =
case forall n i.
Lens' ChatState (MessageInterface n i)
-> ChatState -> Maybe Message
getSelectedMessage Lens' ChatState (MessageInterface Name i)
which ChatState
st of
Maybe Message
Nothing -> forall {n}. Widget n
emptyWidget
Just Message
postMsg ->
let optionList :: Widget n
optionList = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {n}. [Widget n]
usableOptions
then forall n. Text -> Widget n
txt Text
"(no actions available for this message)"
else forall n. [Widget n] -> Widget n
hBox forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (forall n. Text -> Widget n
txt Text
" ") forall {n}. [Widget n]
usableOptions
usableOptions :: [Widget n]
usableOptions = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall {n}. (Message -> Bool, Text, Text) -> Maybe (Widget n)
mkOption forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Message -> Bool, Text, Text)]
options
mkOption :: (Message -> Bool, Text, Text) -> Maybe (Widget n)
mkOption (Message -> Bool
f, Text
k, Text
desc) = if Message -> Bool
f Message
postMsg
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
messageSelectStatusAttr (forall n. Text -> Widget n
txt Text
k) forall n. Widget n -> Widget n -> Widget n
<+>
forall n. Text -> Widget n
txt (Text
":" forall a. Semigroup a => a -> a -> a
<> Text
desc)
else forall a. Maybe a
Nothing
numURLs :: Int
numURLs = forall a. Seq a -> Int
Seq.length forall a b. (a -> b) -> a -> b
$ Message -> Seq LinkChoice
msgURLs Message
postMsg
s :: Text
s = if Int
numURLs forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"" else Text
"s"
hasURLs :: Bool
hasURLs = Int
numURLs forall a. Ord a => a -> a -> Bool
> Int
0
openUrlsMsg :: Text
openUrlsMsg = Text
"open " forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
numURLs) forall a. Semigroup a => a -> a -> a
<> Text
" URL" forall a. Semigroup a => a -> a -> a
<> Text
s
hasVerb :: Bool
hasVerb = forall a. Maybe a -> Bool
isJust (Blocks -> Maybe Text
findVerbatimChunk (Message
postMsgforall s a. s -> Getting a s a -> a
^.Lens' Message Blocks
mText))
ev :: KeyEvent -> Text
ev = ChatState
-> (KeyConfig KeyEvent -> KeyDispatcher KeyEvent MH)
-> KeyEvent
-> Text
keyEventBindings ChatState
st (forall n i.
TeamId
-> Lens' ChatState (MessageInterface n i)
-> KeyConfig KeyEvent
-> KeyDispatcher KeyEvent MH
messageSelectKeybindings TeamId
tId Lens' ChatState (MessageInterface Name i)
which)
options :: [(Message -> Bool, Text, Text)]
options = [ ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Bool
isGap
, KeyEvent -> Text
ev KeyEvent
YankWholeMessageEvent
, Text
"yank-all"
)
, ( \Message
m -> Message -> Bool
isFlaggable Message
m Bool -> Bool -> Bool
&& Bool -> Bool
not (Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mFlagged)
, KeyEvent -> Text
ev KeyEvent
FlagMessageEvent
, Text
"flag"
)
, ( \Message
m -> Message -> Bool
isFlaggable Message
m Bool -> Bool -> Bool
&& Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mFlagged
, KeyEvent -> Text
ev KeyEvent
FlagMessageEvent
, Text
"unflag"
)
, ( Message -> Bool
isReplyable
, KeyEvent -> Text
ev KeyEvent
OpenThreadEvent
, Text
"thread"
)
, ( Message -> Bool
isPostMessage
, KeyEvent -> Text
ev KeyEvent
CopyPostLinkEvent
, Text
"copy-link"
)
, ( \Message
m -> Message -> Bool
isPinnable Message
m Bool -> Bool -> Bool
&& Bool -> Bool
not (Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mPinned)
, KeyEvent -> Text
ev KeyEvent
PinMessageEvent
, Text
"pin"
)
, ( \Message
m -> Message -> Bool
isPinnable Message
m Bool -> Bool -> Bool
&& Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message Bool
mPinned
, KeyEvent -> Text
ev KeyEvent
PinMessageEvent
, Text
"unpin"
)
, ( Message -> Bool
isReplyable
, KeyEvent -> Text
ev KeyEvent
ReplyMessageEvent
, Text
"reply"
)
, ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Bool
isGap
, KeyEvent -> Text
ev KeyEvent
ViewMessageEvent
, Text
"view"
)
, ( Message -> Bool
isGap
, KeyEvent -> Text
ev KeyEvent
FillGapEvent
, Text
"load messages"
)
, ( \Message
m -> ChatState -> Message -> Bool
isMine ChatState
st Message
m Bool -> Bool -> Bool
&& Message -> Bool
isEditable Message
m
, KeyEvent -> Text
ev KeyEvent
EditMessageEvent
, Text
"edit"
)
, ( \Message
m -> ChatState -> Message -> Bool
isMine ChatState
st Message
m Bool -> Bool -> Bool
&& Message -> Bool
isDeletable Message
m
, KeyEvent -> Text
ev KeyEvent
DeleteMessageEvent
, Text
"delete"
)
, ( forall a b. a -> b -> a
const Bool
hasURLs
, KeyEvent -> Text
ev KeyEvent
OpenMessageURLEvent
, Text
openUrlsMsg
)
, ( forall a b. a -> b -> a
const Bool
hasVerb
, KeyEvent -> Text
ev KeyEvent
YankMessageEvent
, Text
"yank-code"
)
, ( Message -> Bool
isReactable
, KeyEvent -> Text
ev KeyEvent
ReactToMessageEvent
, Text
"react"
)
]
in forall n. [Widget n] -> Widget n
hBox [ forall n. Int -> Widget n -> Widget n
hLimit Int
1 forall {n}. Widget n
hBorder
, forall n. Text -> Widget n
txt Text
"["
, forall {n}. Widget n
optionList
, forall n. Text -> Widget n
txt Text
"]"
, forall {n}. Widget n
hBorder
]
renderMessageListing :: ChatState
-> Bool
-> Bool
-> TeamId
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Name
-> Widget Name
renderMessageListing :: forall i.
ChatState
-> Bool
-> Bool
-> TeamId
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Bool
-> Name
-> Widget Name
renderMessageListing ChatState
st Bool
inMsgSelect Bool
showNewMsgLine TeamId
tId HighlightSet
hs Lens' ChatState (MessageInterface Name i)
which Bool
renderReplyIndent Name
region =
Widget Name
messages
where
mcId :: Maybe ChannelId
mcId = ChatState
stforall s a. s -> Getting a s a -> a
^.(TeamId -> SimpleGetter ChatState (Maybe ChannelId)
csCurrentChannelId TeamId
tId)
messages :: Widget Name
messages = forall n. Padding -> Widget n -> Widget n
padTop Padding
Max Widget Name
chatText
chatText :: Widget Name
chatText =
case Maybe ChannelId
mcId of
Maybe ChannelId
Nothing -> forall n. Char -> Widget n
fill Char
' '
Just ChannelId
cId ->
if Bool
inMsgSelect
then forall n. Widget n -> Widget n
freezeBorders forall a b. (a -> b) -> a -> b
$
ChannelId -> MessageSelectState -> Messages -> Widget Name
renderMessagesWithSelect ChannelId
cId (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) MessageSelectState
miMessageSelect) (ChannelId -> Messages
buildMessages ChannelId
cId)
else forall n. Ord n => n -> Widget n -> Widget n
cached Name
region forall a b. (a -> b) -> a -> b
$
forall n. Widget n -> Widget n
freezeBorders forall a b. (a -> b) -> a -> b
$
ChatState
-> HighlightSet
-> Maybe ServerTime
-> Bool
-> Name
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages ChatState
st HighlightSet
hs (ChannelId -> ChatState -> Maybe ServerTime
getEditedMessageCutoff ChannelId
cId ChatState
st) Bool
renderReplyIndent Name
region forall a b. (a -> b) -> a -> b
$
RetrogradeMessages
-> DirectionalSeq Retrograde (Message, ThreadState)
retrogradeMsgsWithThreadStates forall a b. (a -> b) -> a -> b
$
Messages -> RetrogradeMessages
reverseMessages forall a b. (a -> b) -> a -> b
$
ChannelId -> Messages
buildMessages ChannelId
cId
renderMessagesWithSelect :: ChannelId -> MessageSelectState -> Messages -> Widget Name
renderMessagesWithSelect ChannelId
cId (MessageSelectState Maybe MessageId
selMsgId) Messages
msgs =
let (Maybe (Message, ThreadState)
s, (DirectionalSeq
(ReverseDirection Chronological) (Message, ThreadState)
before, DirectionalSeq Chronological (Message, ThreadState)
after)) = forall d a.
SeqDirection d =>
(a -> Bool)
-> DirectionalSeq d a
-> (Maybe a,
(DirectionalSeq (ReverseDirection d) a, DirectionalSeq d a))
splitDirSeqOn (\(Message
m, ThreadState
_) -> Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall a. Eq a => a -> a -> Bool
== Maybe MessageId
selMsgId) DirectionalSeq Chronological (Message, ThreadState)
msgsWithStates
msgsWithStates :: DirectionalSeq Chronological (Message, ThreadState)
msgsWithStates = Messages -> DirectionalSeq Chronological (Message, ThreadState)
chronologicalMsgsWithThreadStates Messages
msgs
in case Maybe (Message, ThreadState)
s of
Maybe (Message, ThreadState)
Nothing ->
ChatState
-> HighlightSet
-> Maybe ServerTime
-> Bool
-> Name
-> DirectionalSeq Retrograde (Message, ThreadState)
-> Widget Name
renderLastMessages ChatState
st HighlightSet
hs (ChannelId -> ChatState -> Maybe ServerTime
getEditedMessageCutoff ChannelId
cId ChatState
st) Bool
renderReplyIndent Name
region DirectionalSeq Retrograde (Message, ThreadState)
before
Just (Message, ThreadState)
m ->
forall dir1 dir2.
(SeqDirection dir1, SeqDirection dir2) =>
((Message, ThreadState),
(DirectionalSeq dir1 (Message, ThreadState),
DirectionalSeq dir2 (Message, ThreadState)))
-> (Message -> ThreadState -> Name -> Widget Name)
-> Name
-> Widget Name
unsafeRenderMessageSelection ((Message, ThreadState)
m, (DirectionalSeq Retrograde (Message, ThreadState)
before, DirectionalSeq Chronological (Message, ThreadState)
after))
(ChatState
-> HighlightSet
-> Bool
-> Maybe ServerTime
-> Message
-> ThreadState
-> Name
-> Widget Name
renderSingleMessage ChatState
st HighlightSet
hs Bool
renderReplyIndent forall a. Maybe a
Nothing) Name
region
buildMessages :: ChannelId -> Messages
buildMessages ChannelId
cId =
let cutoff :: Maybe NewMessageIndicator
cutoff = if Bool
showNewMsgLine
then ChannelId -> ChatState -> Maybe NewMessageIndicator
getNewMessageCutoff ChannelId
cId ChatState
st
else forall a. Maybe a
Nothing
ms :: Messages
ms = ChatState -> Traversal' ChatState Messages -> Messages
filterMessageListing ChatState
st (Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages)
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Messages
ms
then forall a. MessageOps a => Message -> a -> a
addMessage (ChatState -> ChannelId -> Message
emptyChannelFillerMessage ChatState
st ChannelId
cId) forall dir a. DirectionalSeq dir a
emptyDirSeq
else Messages
-> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages
insertTransitions Messages
ms
Maybe NewMessageIndicator
cutoff
(ChatState -> Text
getDateFormat ChatState
st)
(ChatState
st forall s a. s -> Getting a s a -> a
^. Lens' ChatState TimeZoneSeries
timeZone)
insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages
insertTransitions :: Messages
-> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages
insertTransitions Messages
ms Maybe NewMessageIndicator
cutoff = Messages -> Text -> TimeZoneSeries -> Messages
insertDateMarkers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. MessageOps a => Message -> a -> a
addMessage Messages
ms [Message]
newMessagesT
where anyNondeletedNewMessages :: ServerTime -> Bool
anyNondeletedNewMessages ServerTime
t =
forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ (Message -> Bool) -> Messages -> Maybe Message
findLatestUserMessage (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Message Bool
mDeleted) (ServerTime -> Messages -> Messages
messagesAfter ServerTime
t Messages
ms)
newMessagesT :: [Message]
newMessagesT = case Maybe NewMessageIndicator
cutoff of
Maybe NewMessageIndicator
Nothing -> []
Just NewMessageIndicator
Hide -> []
Just (NewPostsAfterServerTime ServerTime
t)
| ServerTime -> Bool
anyNondeletedNewMessages ServerTime
t -> [ServerTime -> Message
newMessagesMsg forall a b. (a -> b) -> a -> b
$ ServerTime -> ServerTime
justAfter ServerTime
t]
| Bool
otherwise -> []
Just (NewPostsStartingAt ServerTime
t)
| ServerTime -> Bool
anyNondeletedNewMessages (ServerTime -> ServerTime
justBefore ServerTime
t) -> [ServerTime -> Message
newMessagesMsg forall a b. (a -> b) -> a -> b
$ ServerTime -> ServerTime
justBefore ServerTime
t]
| Bool
otherwise -> []
newMessagesMsg :: ServerTime -> Message
newMessagesMsg ServerTime
d = Text -> MessageType -> ServerTime -> Message
newMessageOfType (String -> Text
T.pack String
"New Messages")
(ClientMessageType -> MessageType
C ClientMessageType
NewMessagesTransition) ServerTime
d
emptyChannelFillerMessage :: ChatState -> ChannelId -> Message
emptyChannelFillerMessage :: ChatState -> ChannelId -> Message
emptyChannelFillerMessage ChatState
st ChannelId
cId =
Text -> MessageType -> ServerTime -> Message
newMessageOfType Text
msg (ClientMessageType -> MessageType
C ClientMessageType
Informative) ServerTime
ts
where
ts :: ServerTime
ts = UTCTime -> ServerTime
ServerTime forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime (forall a. Enum a => Int -> a
toEnum Int
0) DiffTime
0
chan :: ClientChannel
chan = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ChannelId -> ClientChannels -> Maybe ClientChannel
findChannelById ChannelId
cId (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ClientChannels
csChannels)
chanName :: Text
chanName = ChatState -> ChannelInfo -> Text
mkChannelName ChatState
st (ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfo)
msg :: Text
msg = case ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Type
cdType of
Type
Direct ->
let u :: Maybe UserInfo
u = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo (Maybe UserId)
cdDMUserId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip UserId -> ChatState -> Maybe UserInfo
userById ChatState
st
in case Maybe UserInfo
u of
Maybe UserInfo
Nothing -> forall {a}. (Semigroup a, IsString a) => Maybe a -> a
userMsg forall a. Maybe a
Nothing
Just UserInfo
_ -> forall {a}. (Semigroup a, IsString a) => Maybe a -> a
userMsg (forall a. a -> Maybe a
Just Text
chanName)
Type
Group ->
forall {a}. (Semigroup a, IsString a) => a -> a
groupMsg (ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Text
cdDisplayName)
Type
_ ->
forall {a}. (Semigroup a, IsString a) => a -> a
chanMsg Text
chanName
userMsg :: Maybe a -> a
userMsg (Just a
cn) = a
"You have not yet sent any direct messages to " forall a. Semigroup a => a -> a -> a
<> a
cn forall a. Semigroup a => a -> a -> a
<> a
"."
userMsg Maybe a
Nothing = a
"You have not yet sent any direct messages to this user."
groupMsg :: a -> a
groupMsg a
us = a
"There are not yet any direct messages in the group " forall a. Semigroup a => a -> a -> a
<> a
us forall a. Semigroup a => a -> a -> a
<> a
"."
chanMsg :: a -> a
chanMsg a
cn = a
"There are not yet any messages in the " forall a. Semigroup a => a -> a -> a
<> a
cn forall a. Semigroup a => a -> a -> a
<> a
" channel."
filterMessageListing :: ChatState -> Traversal' ChatState Messages -> Messages
filterMessageListing :: ChatState -> Traversal' ChatState Messages -> Messages
filterMessageListing ChatState
st Traversal' ChatState Messages
msgsWhich =
ChatState
st forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Traversal' ChatState Messages
msgsWhich forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to (forall seq a.
SeqDirection seq =>
(a -> Bool) -> DirectionalSeq seq a -> DirectionalSeq seq a
filterMessages Message -> Bool
isShown)
where isShown :: Message -> Bool
isShown Message
m
| ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources UserPreferences
crUserPreferencesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' UserPreferences Bool
userPrefShowJoinLeave = Bool
True
| Bool
otherwise = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Message -> Bool
isJoinLeave Message
m
inputArea :: ChatState
-> Lens' ChatState (EditState Name)
-> Bool
-> HighlightSet
-> Widget Name
inputArea :: ChatState
-> Lens' ChatState (EditState Name)
-> Bool
-> HighlightSet
-> Widget Name
inputArea ChatState
st Lens' ChatState (EditState Name)
which Bool
focused HighlightSet
hs =
let replyPrompt :: Text
replyPrompt = Text
"reply> "
normalPrompt :: Text
normalPrompt = Text
"> "
editPrompt :: Text
editPrompt = Text
"edit> "
showReplyPrompt :: Bool
showReplyPrompt = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (EditState Name)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) Bool
esShowReplyPrompt
maybeHighlight :: Widget n -> Widget n
maybeHighlight = if Bool
focused
then forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
focusedEditorPromptAttr
else forall a. a -> a
id
prompt :: Widget Name
prompt = forall n. Widget n -> Widget n
maybeHighlight forall a b. (a -> b) -> a -> b
$
forall n. Ord n => n -> Widget n -> Widget n
reportExtent (Name -> Name
MessageInputPrompt forall a b. (a -> b) -> a -> b
$ forall a n. Named a n => a -> n
getName Editor Text Name
editor) forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ case ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (EditState Name)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EditMode
esEditMode of
Replying {} ->
if Bool
showReplyPrompt then Text
replyPrompt else Text
normalPrompt
Editing {} ->
Text
editPrompt
EditMode
NewPost ->
Text
normalPrompt
editor :: Editor Text Name
editor = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (EditState Name)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) (Editor Text n)
esEditor
inputBox :: Widget Name
inputBox = forall n t.
(Ord n, Show n, Monoid t, TextWidth t, GenericTextZipper t) =>
([t] -> Widget n) -> Bool -> Editor t n -> Widget n
renderEditor (ChatState
-> SimpleGetter ChatState (EditState Name)
-> HighlightSet
-> [Text]
-> Widget Name
drawEditorContents ChatState
st Lens' ChatState (EditState Name)
which HighlightSet
hs) Bool
True Editor Text Name
editor
curContents :: [Text]
curContents = forall t n. Monoid t => Editor t n -> [t]
getEditContents Editor Text Name
editor
multilineContent :: Bool
multilineContent = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
curContents forall a. Ord a => a -> a -> Bool
> Int
1
multilineHints :: Widget n
multilineHints =
forall n. [Widget n] -> Widget n
hBox [ forall n. Int -> Widget n -> Widget n
hLimit Int
1 forall {n}. Widget n
hBorder
, forall n. String -> Widget n
str forall a b. (a -> b) -> a -> b
$ String
"[" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. TextZipper a -> (Int, Int)
cursorPosition forall a b. (a -> b) -> a -> b
$
Editor Text Name
editorforall s a. s -> Getting a s a -> a
^.forall t1 n t2.
Lens (Editor t1 n) (Editor t2 n) (TextZipper t1) (TextZipper t2)
editContentsL) forall a. Semigroup a => a -> a -> a
<>
String
"/" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
curContents) forall a. Semigroup a => a -> a -> a
<> String
"]"
, forall n. Widget n -> Widget n
hBorderWithLabel forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ Text
"In multi-line mode. Press " forall a. Semigroup a => a -> a -> a
<> Text
multiLineToggleKey forall a. Semigroup a => a -> a -> a
<>
Text
" to finish."
]
replyDisplay :: Widget Name
replyDisplay = case ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (EditState Name)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EditMode
esEditMode of
Replying Message
msg Post
_ | Bool
showReplyPrompt ->
let msgWithoutParent :: Message
msgWithoutParent = Message
msg forall a b. a -> (a -> b) -> b
& Lens' Message ReplyState
mInReplyToMsg forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReplyState
NotAReply
in forall n. [Widget n] -> Widget n
hBox [ forall {n}. Widget n
replyArrow
, forall n. Widget n -> Widget n
addEllipsis forall a b. (a -> b) -> a -> b
$ MessageData -> Widget Name
renderMessage MessageData
{ mdMessage :: Message
mdMessage = Message
msgWithoutParent
, mdUserName :: Maybe Text
mdUserName = Message
msgWithoutParentforall s a. s -> Getting a s a -> a
^.Lens' Message UserRef
mUserforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st)
, mdParentMessage :: Maybe Message
mdParentMessage = forall a. Maybe a
Nothing
, mdParentUserName :: Maybe Text
mdParentUserName = forall a. Maybe a
Nothing
, mdHighlightSet :: HighlightSet
mdHighlightSet = HighlightSet
hs
, mdEditThreshold :: Maybe ServerTime
mdEditThreshold = forall a. Maybe a
Nothing
, mdShowOlderEdits :: Bool
mdShowOlderEdits = Bool
False
, mdRenderReplyParent :: Bool
mdRenderReplyParent = Bool
True
, mdRenderReplyIndent :: Bool
mdRenderReplyIndent = Bool
True
, mdIndentBlocks :: Bool
mdIndentBlocks = Bool
False
, mdThreadState :: ThreadState
mdThreadState = ThreadState
NoThread
, mdShowReactions :: Bool
mdShowReactions = Bool
True
, mdMessageWidthLimit :: Maybe Int
mdMessageWidthLimit = forall a. Maybe a
Nothing
, mdMyUsername :: Text
mdMyUsername = ChatState -> Text
myUsername ChatState
st
, mdMyUserId :: UserId
mdMyUserId = ChatState -> UserId
myUserId ChatState
st
, mdWrapNonhighlightedCodeBlocks :: Bool
mdWrapNonhighlightedCodeBlocks = Bool
True
, mdTruncateVerbatimBlocks :: Maybe Int
mdTruncateVerbatimBlocks = forall a. Maybe a
Nothing
, mdClickableNameTag :: Name
mdClickableNameTag = forall a n. Named a n => a -> n
getName Editor Text Name
editor
}
]
EditMode
_ -> forall {n}. Widget n
emptyWidget
kc :: KeyConfig KeyEvent
kc = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config (KeyConfig KeyEvent)
configUserKeysL
multiLineToggleKey :: Text
multiLineToggleKey = Maybe Binding -> Text
ppMaybeBinding forall a b. (a -> b) -> a -> b
$ forall k. (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding
firstActiveBinding KeyConfig KeyEvent
kc KeyEvent
ToggleMultiLineEvent
commandBox :: Widget Name
commandBox = case ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (EditState Name)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EphemeralEditState
esEphemeralforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' EphemeralEditState Bool
eesMultiline of
Bool
False ->
let linesStr :: String
linesStr = String
"line" forall a. Semigroup a => a -> a -> a
<> if Int
numLines forall a. Eq a => a -> a -> Bool
== Int
1 then String
"" else String
"s"
numLines :: Int
numLines = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
curContents
in forall n. Int -> Widget n -> Widget n
vLimit Int
1 forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
hBox forall a b. (a -> b) -> a -> b
$
Widget Name
prompt forall a. a -> [a] -> [a]
: if Bool
multilineContent
then [ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$
forall n. String -> Widget n
str forall a b. (a -> b) -> a -> b
$ String
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
numLines forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
linesStr forall a. Semigroup a => a -> a -> a
<>
String
"; Enter: send, " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
multiLineToggleKey forall a. Semigroup a => a -> a -> a
<>
String
": edit, Backspace: cancel] "
, forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Text]
curContents
, forall n. n -> Location -> Widget n -> Widget n
showCursor (forall a n. Named a n => a -> n
getName Editor Text Name
editor) ((Int, Int) -> Location
Location (Int
0,Int
0)) forall a b. (a -> b) -> a -> b
$ forall n. String -> Widget n
str String
" "
]
else [Widget Name
inputBox]
Bool
True -> forall n. Int -> Widget n -> Widget n
vLimit Int
multilineHeightLimit Widget Name
inputBox forall n. Widget n -> Widget n -> Widget n
<=> forall {n}. Widget n
multilineHints
in Widget Name
replyDisplay forall n. Widget n -> Widget n -> Widget n
<=> Widget Name
commandBox
drawEditorContents :: ChatState
-> SimpleGetter ChatState (EditState Name)
-> HighlightSet
-> [Text]
-> Widget Name
drawEditorContents :: ChatState
-> SimpleGetter ChatState (EditState Name)
-> HighlightSet
-> [Text]
-> Widget Name
drawEditorContents ChatState
st SimpleGetter ChatState (EditState Name)
editWhich HighlightSet
hs =
let noHighlight :: [Text] -> Widget n
noHighlight = forall n. Text -> Widget n
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines
ms :: Set Text
ms = ChatState
stforall s a. s -> Getting a s a -> a
^.SimpleGetter ChatState (EditState Name)
editWhichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) (Set Text)
esMisspellings
in case forall a. Set a -> Bool
S.null Set Text
ms of
Bool
True -> forall {n}. [Text] -> Widget n
noHighlight
Bool
False -> HighlightSet -> Set Text -> [Text] -> Widget Name
doHighlightMisspellings HighlightSet
hs Set Text
ms
replyArrow :: Widget a
replyArrow :: forall {n}. Widget n
replyArrow =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Context a
ctx <- forall n. RenderM n (Context n)
getContext
let bs :: BorderStyle
bs = Context a
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) BorderStyle
ctxBorderStyleL
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. String -> Widget n
str [Char
' ', BorderStyle -> Char
bsCornerTL BorderStyle
bs, Char
'▸']
data Token =
Ignore Text
| Check Text
deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)
doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name
doHighlightMisspellings :: HighlightSet -> Set Text -> [Text] -> Widget Name
doHighlightMisspellings HighlightSet
hs Set Text
misspellings [Text]
contents =
let whitelist :: Set Text
whitelist = forall a. Ord a => Set a -> Set a -> Set a
S.union (HighlightSet -> Set Text
hUserSet HighlightSet
hs) (HighlightSet -> Set Text
hChannelSet HighlightSet
hs)
handleLine :: Text -> Widget n
handleLine Text
t | Text
t forall a. Eq a => a -> a -> Bool
== Text
"" = forall n. Text -> Widget n
txt Text
" "
handleLine Text
t =
let mkW :: Either Token Token -> Widget n
mkW (Left Token
tok) =
let s :: Text
s = Token -> Text
getTokenText Token
tok
in if Text -> Bool
T.null Text
s
then forall {n}. Widget n
emptyWidget
else forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
misspellingAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ Token -> Text
getTokenText Token
tok
mkW (Right Token
tok) =
let s :: Text
s = Token -> Text
getTokenText Token
tok
in if Text -> Bool
T.null Text
s
then forall {n}. Widget n
emptyWidget
else forall n. Text -> Widget n
txt Text
s
go :: Either Token Token -> [Either Token Token] -> [Either Token Token]
go :: Either Token Token -> [Either Token Token] -> [Either Token Token]
go Either Token Token
lst [] = [Either Token Token
lst]
go Either Token Token
lst (Either Token Token
tok:[Either Token Token]
toks) =
case (Either Token Token
lst, Either Token Token
tok) of
(Left Token
a, Left Token
b) -> Either Token Token -> [Either Token Token] -> [Either Token Token]
go (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Token -> Token -> Token
combineTokens Token
a Token
b) [Either Token Token]
toks
(Right Token
a, Right Token
b) -> Either Token Token -> [Either Token Token] -> [Either Token Token]
go (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Token -> Token -> Token
combineTokens Token
a Token
b) [Either Token Token]
toks
(Either Token Token, Either Token Token)
_ -> Either Token Token
lst forall a. a -> [a] -> [a]
: Either Token Token -> [Either Token Token] -> [Either Token Token]
go Either Token Token
tok [Either Token Token]
toks
in forall n. [Widget n] -> Widget n
hBox forall a b. (a -> b) -> a -> b
$ forall {n}. Either Token Token -> Widget n
mkW forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either Token Token -> [Either Token Token] -> [Either Token Token]
go (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Token
Ignore Text
"") forall a b. (a -> b) -> a -> b
$ Text -> [Either Token Token]
annotatedTokens Text
t)
combineTokens :: Token -> Token -> Token
combineTokens (Ignore Text
a) (Ignore Text
b) = Text -> Token
Ignore forall a b. (a -> b) -> a -> b
$ Text
a forall a. Semigroup a => a -> a -> a
<> Text
b
combineTokens (Check Text
a) (Check Text
b) = Text -> Token
Check forall a b. (a -> b) -> a -> b
$ Text
a forall a. Semigroup a => a -> a -> a
<> Text
b
combineTokens (Ignore Text
a) (Check Text
b) = Text -> Token
Check forall a b. (a -> b) -> a -> b
$ Text
a forall a. Semigroup a => a -> a -> a
<> Text
b
combineTokens (Check Text
a) (Ignore Text
b) = Text -> Token
Check forall a b. (a -> b) -> a -> b
$ Text
a forall a. Semigroup a => a -> a -> a
<> Text
b
getTokenText :: Token -> Text
getTokenText (Ignore Text
a) = Text
a
getTokenText (Check Text
a) = Text
a
annotatedTokens :: Text -> [Either Token Token]
annotatedTokens Text
t =
Token -> Either Token Token
checkMisspelling forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Token -> [Token]
tokenize Text
t (Text -> Token
Ignore Text
"")
checkMisspelling :: Token -> Either Token Token
checkMisspelling t :: Token
t@(Ignore Text
_) = forall a b. b -> Either a b
Right Token
t
checkMisspelling t :: Token
t@(Check Text
s) =
if Text
s forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
whitelist
then forall a b. b -> Either a b
Right Token
t
else if Text
s forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
misspellings
then forall a b. a -> Either a b
Left Token
t
else forall a b. b -> Either a b
Right Token
t
ignoreChar :: Char -> Bool
ignoreChar Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'`' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
||
Char -> Text
T.singleton Char
c forall a. Eq a => a -> a -> Bool
== Text
userSigil Bool -> Bool -> Bool
|| Char -> Text
T.singleton Char
c forall a. Eq a => a -> a -> Bool
== Text
normalChannelSigil
tokenize :: Text -> Token -> [Token]
tokenize Text
t Token
curTok
| Text -> Bool
T.null Text
t = [Token
curTok]
| Char -> Bool
ignoreChar forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t =
case Token
curTok of
Ignore Text
s -> Text -> Token -> [Token]
tokenize (Text -> Text
T.tail Text
t) (Text -> Token
Ignore forall a b. (a -> b) -> a -> b
$ Text
s forall a. Semigroup a => a -> a -> a
<> (Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t))
Check Text
s -> Text -> Token
Check Text
s forall a. a -> [a] -> [a]
: Text -> Token -> [Token]
tokenize (Text -> Text
T.tail Text
t) (Text -> Token
Ignore forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t)
| Bool
otherwise =
case Token
curTok of
Ignore Text
s -> Text -> Token
Ignore Text
s forall a. a -> [a] -> [a]
: Text -> Token -> [Token]
tokenize (Text -> Text
T.tail Text
t) (Text -> Token
Check forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t)
Check Text
s -> Text -> Token -> [Token]
tokenize (Text -> Text
T.tail Text
t) (Text -> Token
Check forall a b. (a -> b) -> a -> b
$ Text
s forall a. Semigroup a => a -> a -> a
<> (Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t))
in forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
handleLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
contents
drawSaveAttachmentWindow :: ChatState
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
drawSaveAttachmentWindow :: forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
drawSaveAttachmentWindow ChatState
st Lens' ChatState (MessageInterface Name i)
which =
forall n. Widget n -> Widget n
center forall a b. (a -> b) -> a -> b
$
forall n. Int -> Widget n -> Widget n
padAll Int
2 forall a b. (a -> b) -> a -> b
$
forall n. Widget n -> Widget n -> Widget n
borderWithLabel (forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
"Save Attachment") forall a b. (a -> b) -> a -> b
$
forall n. [Widget n] -> Widget n
vBox [ forall n. Int -> Widget n -> Widget n
padAll Int
1 forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt Text
"Path: " forall n. Widget n -> Widget n -> Widget n
<+>
(forall n. Int -> Widget n -> Widget n
vLimit Int
editorHeight forall a b. (a -> b) -> a -> b
$
forall n a b.
(Eq n, Named a n) =>
FocusRing n -> (Bool -> a -> b) -> a -> b
withFocusRing FocusRing Name
foc (forall n t.
(Ord n, Show n, Monoid t, TextWidth t, GenericTextZipper t) =>
([t] -> Widget n) -> Bool -> Editor t n -> Widget n
renderEditor forall {n}. [Text] -> Widget n
drawEditorTxt) Editor Text Name
ed)
, forall n. [Widget n] -> Widget n
hBox [ forall n. Padding -> Widget n -> Widget n
padRight Padding
Max forall a b. (a -> b) -> a -> b
$
forall n. Padding -> Widget n -> Widget n
padLeft (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$
forall n. (Eq n, Ord n) => FocusRing n -> n -> Text -> Widget n
drawButton FocusRing Name
foc (Name -> Name
AttachmentPathSaveButton Name
listName) Text
"Save"
, forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$
forall n. (Eq n, Ord n) => FocusRing n -> n -> Text -> Widget n
drawButton FocusRing Name
foc (Name -> Name
AttachmentPathCancelButton Name
listName) Text
"Cancel"
]
]
where
editorHeight :: Int
editorHeight = Int
1
listName :: Name
listName = forall a n. Named a n => a -> n
getName forall a b. (a -> b) -> a -> b
$ ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (URLList n)
miUrlListforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n1 n2.
Lens
(URLList n1)
(URLList n2)
(List n1 (Int, LinkChoice))
(List n2 (Int, LinkChoice))
ulList
foc :: FocusRing Name
foc = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i.
Lens' (MessageInterface n i) (SaveAttachmentDialogState n)
miSaveAttachmentDialogforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (SaveAttachmentDialogState n) (FocusRing n)
attachmentPathDialogFocus
ed :: Editor Text Name
ed = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i.
Lens' (MessageInterface n i) (SaveAttachmentDialogState n)
miSaveAttachmentDialogforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (SaveAttachmentDialogState n) (Editor Text n)
attachmentPathEditor
drawEditorTxt :: [Text] -> Widget n
drawEditorTxt = forall n. Text -> Widget n
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines
drawUrlSelectWindow :: ChatState -> HighlightSet -> Lens' ChatState (MessageInterface Name i) -> Widget Name
drawUrlSelectWindow :: forall i.
ChatState
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
drawUrlSelectWindow ChatState
st HighlightSet
hs Lens' ChatState (MessageInterface Name i)
which =
forall n. [Widget n] -> Widget n
vBox [ forall i.
ChatState
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
renderUrlList ChatState
st HighlightSet
hs Lens' ChatState (MessageInterface Name i)
which
, forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectBottomBar ChatState
st Lens' ChatState (MessageInterface Name i)
which
, forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectInputArea ChatState
st Lens' ChatState (MessageInterface Name i)
which
]
renderUrlList :: ChatState -> HighlightSet -> Lens' ChatState (MessageInterface Name i) -> Widget Name
renderUrlList :: forall i.
ChatState
-> HighlightSet
-> Lens' ChatState (MessageInterface Name i)
-> Widget Name
renderUrlList ChatState
st HighlightSet
hs Lens' ChatState (MessageInterface Name i)
which =
Widget Name
urlDisplay
where
urlDisplay :: Widget Name
urlDisplay = if forall (t :: * -> *) a. Foldable t => t a -> Int
F.length List Name (Int, LinkChoice)
urls forall a. Eq a => a -> a -> Bool
== Int
0
then forall n. String -> Widget n
str String
"No links found." forall n. Widget n -> Widget n -> Widget n
<=> forall n. Char -> Widget n
fill Char
' '
else forall (t :: * -> *) n e.
(Traversable t, Splittable t, Ord n, Show n) =>
(Bool -> e -> Widget n) -> Bool -> GenericList n t e -> Widget n
renderList Bool -> (Int, LinkChoice) -> Widget Name
renderItem Bool
True List Name (Int, LinkChoice)
urls
urls :: List Name (Int, LinkChoice)
urls = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (URLList n)
miUrlListforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n1 n2.
Lens
(URLList n1)
(URLList n2)
(List n1 (Int, LinkChoice))
(List n2 (Int, LinkChoice))
ulList
me :: Text
me = ChatState -> Text
myUsername ChatState
st
renderItem :: Bool -> (Int, LinkChoice) -> Widget Name
renderItem Bool
sel (Int
i, LinkChoice
link) =
let time :: ServerTime
time = LinkChoice
linkforall s a. s -> Getting a s a -> a
^.Lens' LinkChoice ServerTime
linkTime
in forall {n}. Bool -> Widget n -> Widget n
attr Bool
sel forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
vLimit Int
2 forall a b. (a -> b) -> a -> b
$
(forall n. Int -> Widget n -> Widget n
vLimit Int
1 forall a b. (a -> b) -> a -> b
$
forall n. [Widget n] -> Widget n
hBox [ let u :: Text
u = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<server>" forall a. a -> a
id (LinkChoice
linkforall s a. s -> Getting a s a -> a
^.Lens' LinkChoice UserRef
linkUserforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st))
in forall a. Text -> Text -> Text -> Widget a
colorUsername Text
me Text
u Text
u
, case LinkChoice
linkforall s a. s -> Getting a s a -> a
^.Lens' LinkChoice (Maybe Inlines)
linkLabel of
Maybe Inlines
Nothing -> forall {n}. Widget n
emptyWidget
Just Inlines
label ->
case forall a. Seq a -> Bool
Seq.null (Inlines -> Seq Inline
unInlines Inlines
label) of
Bool
True -> forall {n}. Widget n
emptyWidget
Bool
False -> forall n. Text -> Widget n
txt Text
": " forall n. Widget n -> Widget n -> Widget n
<+> forall a.
SemEq a =>
Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> Blocks
-> Widget a
renderRichText Text
me HighlightSet
hs forall a. Maybe a
Nothing Bool
False forall a. Maybe a
Nothing forall a. Maybe a
Nothing
(Seq Block -> Blocks
Blocks forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
Seq.singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Block
Para Inlines
label)
, forall n. Char -> Widget n
fill Char
' '
, ChatState -> UTCTime -> Widget Name
renderDate ChatState
st forall a b. (a -> b) -> a -> b
$ ServerTime -> UTCTime
withServerTime ServerTime
time
, forall n. String -> Widget n
str String
" "
, ChatState -> UTCTime -> Widget Name
renderTime ChatState
st forall a b. (a -> b) -> a -> b
$ ServerTime -> UTCTime
withServerTime ServerTime
time
] ) forall n. Widget n -> Widget n -> Widget n
<=>
(forall n. Int -> Widget n -> Widget n
vLimit Int
1 (forall n. Ord n => n -> Widget n -> Widget n
clickable (Int -> LinkTarget -> Name
ClickableURLListEntry Int
i (LinkChoice
linkforall s a. s -> Getting a s a -> a
^.Lens' LinkChoice LinkTarget
linkTarget)) forall a b. (a -> b) -> a -> b
$ forall {a}. SemEq a => LinkTarget -> Widget a
renderLinkTarget (LinkChoice
linkforall s a. s -> Getting a s a -> a
^.Lens' LinkChoice LinkTarget
linkTarget)))
renderLinkTarget :: LinkTarget -> Widget a
renderLinkTarget (LinkPermalink (TeamURLName Text
tName) PostId
pId) =
forall a. SemEq a => Text -> Widget a
renderText forall a b. (a -> b) -> a -> b
$ Text
"Team: " forall a. Semigroup a => a -> a -> a
<> Text
tName forall a. Semigroup a => a -> a -> a
<> Text
", post " forall a. Semigroup a => a -> a -> a
<> forall x. IsId x => x -> Text
idString PostId
pId
renderLinkTarget (LinkURL URL
url) = forall a. SemEq a => Text -> Widget a
renderText forall a b. (a -> b) -> a -> b
$ URL -> Text
unURL URL
url
renderLinkTarget (LinkFileId FileId
_) = forall n. Text -> Widget n
txt Text
" "
attr :: Bool -> Widget n -> Widget n
attr Bool
True = forall n. AttrName -> Widget n -> Widget n
forceAttr AttrName
urlListSelectedAttr
attr Bool
False = forall a. a -> a
id
urlSelectBottomBar :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectBottomBar :: forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectBottomBar ChatState
st Lens' ChatState (MessageInterface Name i)
which =
case forall (t :: * -> *) e n.
(Splittable t, Traversable t, Semigroup (t e)) =>
GenericList n t e -> Maybe (Int, e)
listSelectedElement forall a b. (a -> b) -> a -> b
$ ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState (MessageInterface Name i)
whichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (URLList n)
miUrlListforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n1 n2.
Lens
(URLList n1)
(URLList n2)
(List n1 (Int, LinkChoice))
(List n2 (Int, LinkChoice))
ulList of
Maybe (Int, (Int, LinkChoice))
Nothing -> forall {n}. Widget n
hBorder
Just (Int
_, (Int
_, LinkChoice
link)) ->
let options :: [(LinkChoice -> Bool, Text, Text)]
options = [ ( LinkChoice -> Bool
isFile
, KeyEvent -> Text
ev KeyEvent
SaveAttachmentEvent
, Text
"save attachment"
)
]
ev :: KeyEvent -> Text
ev = ChatState
-> (KeyConfig KeyEvent -> KeyDispatcher KeyEvent MH)
-> KeyEvent
-> Text
keyEventBindings ChatState
st (forall i.
Lens' ChatState (MessageInterface Name i)
-> KeyConfig KeyEvent -> KeyDispatcher KeyEvent MH
urlSelectKeybindings Lens' ChatState (MessageInterface Name i)
which)
isFile :: LinkChoice -> Bool
isFile LinkChoice
entry = case LinkChoice
entryforall s a. s -> Getting a s a -> a
^.Lens' LinkChoice LinkTarget
linkTarget of
LinkFileId {} -> Bool
True
LinkTarget
_ -> Bool
False
optionList :: Widget n
optionList = forall n. [Widget n] -> Widget n
hBox forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (forall n. Text -> Widget n
txt Text
" ") forall {n}. [Widget n]
usableOptions
usableOptions :: [Widget n]
usableOptions = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall {n}. (LinkChoice -> Bool, Text, Text) -> Maybe (Widget n)
mkOption forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LinkChoice -> Bool, Text, Text)]
options
mkOption :: (LinkChoice -> Bool, Text, Text) -> Maybe (Widget n)
mkOption (LinkChoice -> Bool
f, Text
k, Text
desc) = if LinkChoice -> Bool
f LinkChoice
link
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
urlSelectStatusAttr (forall n. Text -> Widget n
txt Text
k) forall n. Widget n -> Widget n -> Widget n
<+>
forall n. Text -> Widget n
txt (Text
":" forall a. Semigroup a => a -> a -> a
<> Text
desc)
else forall a. Maybe a
Nothing
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {n}. [Widget n]
usableOptions
then forall {n}. Widget n
hBorder
else forall n. [Widget n] -> Widget n
hBox [ forall n. Int -> Widget n -> Widget n
hLimit Int
1 forall {n}. Widget n
hBorder
, forall n. Text -> Widget n
txt Text
"["
, forall n. Text -> Widget n
txt Text
"Options: "
, forall {n}. Widget n
optionList
, forall n. Text -> Widget n
txt Text
"]"
, forall {n}. Widget n
hBorder
]
urlSelectInputArea :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectInputArea :: forall i.
ChatState
-> Lens' ChatState (MessageInterface Name i) -> Widget Name
urlSelectInputArea ChatState
st Lens' ChatState (MessageInterface Name i)
which =
let getBinding :: KeyEvent -> Text
getBinding = ChatState
-> (KeyConfig KeyEvent -> KeyDispatcher KeyEvent MH)
-> KeyEvent
-> Text
keyEventBindings ChatState
st (forall i.
Lens' ChatState (MessageInterface Name i)
-> KeyConfig KeyEvent -> KeyDispatcher KeyEvent MH
urlSelectKeybindings Lens' ChatState (MessageInterface Name i)
which)
in forall n. Widget n -> Widget n
hCenter forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
hBox [ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
"Enter"
, forall n. Text -> Widget n
txt Text
":open "
, forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt forall a b. (a -> b) -> a -> b
$ KeyEvent -> Text
getBinding KeyEvent
CancelEvent
, forall n. Text -> Widget n
txt Text
":close"
]