matterhorn 50200.16.0 → 50200.17.0
raw patch · 121 files changed
+7981/−6498 lines, 121 filesdep ~brickdep ~mattermost-api
Dependency ranges changed: brick, mattermost-api
Files
- CHANGELOG.md +71/−2
- README.md +1/−0
- docs/commands.md +3/−1
- docs/keybindings.md +31/−25
- matterhorn.cabal +32/−22
- src/Matterhorn/App.hs +39/−35
- src/Matterhorn/Command.hs +25/−12
- src/Matterhorn/Command.hs-boot +2/−1
- src/Matterhorn/Config.hs +16/−0
- src/Matterhorn/Draw.hs +44/−37
- src/Matterhorn/Draw/Autocomplete.hs +77/−26
- src/Matterhorn/Draw/ChannelList.hs +11/−7
- src/Matterhorn/Draw/ChannelListOverlay.hs +0/−53
- src/Matterhorn/Draw/ChannelListWindow.hs +53/−0
- src/Matterhorn/Draw/ChannelSelectPrompt.hs +28/−0
- src/Matterhorn/Draw/InputPreview.hs +135/−0
- src/Matterhorn/Draw/ListOverlay.hs +0/−134
- src/Matterhorn/Draw/ListWindow.hs +134/−0
- src/Matterhorn/Draw/Main.hs +141/−802
- src/Matterhorn/Draw/ManageAttachments.hs +11/−26
- src/Matterhorn/Draw/MessageDeleteConfirm.hs +28/−0
- src/Matterhorn/Draw/MessageInterface.hs +676/−0
- src/Matterhorn/Draw/Messages.hs +66/−40
- src/Matterhorn/Draw/PostListOverlay.hs +0/−109
- src/Matterhorn/Draw/PostListWindow.hs +110/−0
- src/Matterhorn/Draw/ReactionEmojiListOverlay.hs +0/−42
- src/Matterhorn/Draw/ReactionEmojiListWindow.hs +42/−0
- src/Matterhorn/Draw/SaveAttachmentWindow.hs +0/−46
- src/Matterhorn/Draw/ShowHelp.hs +47/−28
- src/Matterhorn/Draw/TabbedWindow.hs +2/−2
- src/Matterhorn/Draw/ThemeListOverlay.hs +0/−55
- src/Matterhorn/Draw/ThemeListWindow.hs +55/−0
- src/Matterhorn/Draw/URLList.hs +0/−80
- src/Matterhorn/Draw/UserListOverlay.hs +0/−79
- src/Matterhorn/Draw/UserListWindow.hs +79/−0
- src/Matterhorn/Draw/Util.hs +27/−1
- src/Matterhorn/Events.hs +53/−51
- src/Matterhorn/Events/ChannelListOverlay.hs +0/−37
- src/Matterhorn/Events/ChannelListWindow.hs +37/−0
- src/Matterhorn/Events/ChannelSelect.hs +14/−9
- src/Matterhorn/Events/ChannelTopicWindow.hs +4/−4
- src/Matterhorn/Events/DeleteChannelConfirm.hs +4/−2
- src/Matterhorn/Events/EditNotifyPrefs.hs +5/−2
- src/Matterhorn/Events/Keybindings.hs +11/−12
- src/Matterhorn/Events/LeaveChannelConfirm.hs +1/−1
- src/Matterhorn/Events/Main.hs +26/−87
- src/Matterhorn/Events/ManageAttachments.hs +86/−77
- src/Matterhorn/Events/MessageInterface.hs +150/−0
- src/Matterhorn/Events/MessageSelect.hs +61/−35
- src/Matterhorn/Events/Mouse.hs +33/−25
- src/Matterhorn/Events/PostListOverlay.hs +0/−30
- src/Matterhorn/Events/PostListWindow.hs +30/−0
- src/Matterhorn/Events/ReactionEmojiListOverlay.hs +0/−44
- src/Matterhorn/Events/ReactionEmojiListWindow.hs +44/−0
- src/Matterhorn/Events/SaveAttachmentWindow.hs +29/−23
- src/Matterhorn/Events/ShowHelp.hs +10/−9
- src/Matterhorn/Events/TabbedWindow.hs +9/−8
- src/Matterhorn/Events/ThemeListOverlay.hs +0/−39
- src/Matterhorn/Events/ThemeListWindow.hs +39/−0
- src/Matterhorn/Events/ThreadWindow.hs +22/−0
- src/Matterhorn/Events/UrlSelect.hs +17/−16
- src/Matterhorn/Events/UserListOverlay.hs +0/−32
- src/Matterhorn/Events/UserListWindow.hs +32/−0
- src/Matterhorn/Events/Websocket.hs +1/−1
- src/Matterhorn/HelpTopics.hs +5/−7
- src/Matterhorn/LastRunState.hs +7/−0
- src/Matterhorn/Scripts.hs +13/−8
- src/Matterhorn/State/Async.hs +6/−0
- src/Matterhorn/State/Attachments.hs +23/−30
- src/Matterhorn/State/Autocomplete.hs +143/−101
- src/Matterhorn/State/ChannelListOverlay.hs +0/−84
- src/Matterhorn/State/ChannelListWindow.hs +85/−0
- src/Matterhorn/State/ChannelSelect.hs +1/−1
- src/Matterhorn/State/ChannelTopicWindow.hs +2/−1
- src/Matterhorn/State/Channels.hs +72/−85
- src/Matterhorn/State/Common.hs +52/−6
- src/Matterhorn/State/Editing.hs +211/−169
- src/Matterhorn/State/Editing.hs-boot +4/−3
- src/Matterhorn/State/Flagging.hs +24/−13
- src/Matterhorn/State/Help.hs +2/−2
- src/Matterhorn/State/Links.hs +1/−1
- src/Matterhorn/State/ListOverlay.hs +0/−154
- src/Matterhorn/State/ListWindow.hs +159/−0
- src/Matterhorn/State/MessageSelect.hs +218/−215
- src/Matterhorn/State/Messages.hs +109/−43
- src/Matterhorn/State/Messages.hs-boot +18/−3
- src/Matterhorn/State/NotifyPrefs.hs +2/−3
- src/Matterhorn/State/PostListOverlay.hs +0/−147
- src/Matterhorn/State/PostListWindow.hs +147/−0
- src/Matterhorn/State/ReactionEmojiListOverlay.hs +0/−113
- src/Matterhorn/State/ReactionEmojiListWindow.hs +104/−0
- src/Matterhorn/State/Reactions.hs +22/−10
- src/Matterhorn/State/SaveAttachmentWindow.hs +20/−7
- src/Matterhorn/State/Setup.hs +3/−0
- src/Matterhorn/State/Setup/Threads.hs +22/−15
- src/Matterhorn/State/Teams.hs +253/−19
- src/Matterhorn/State/Teams.hs-boot +14/−0
- src/Matterhorn/State/ThemeListOverlay.hs +0/−87
- src/Matterhorn/State/ThemeListWindow.hs +87/−0
- src/Matterhorn/State/ThreadWindow.hs +64/−0
- src/Matterhorn/State/ThreadWindow.hs-boot +14/−0
- src/Matterhorn/State/UrlSelect.hs +24/−21
- src/Matterhorn/State/UserListOverlay.hs +0/−171
- src/Matterhorn/State/UserListWindow.hs +171/−0
- src/Matterhorn/State/Users.hs +16/−3
- src/Matterhorn/Themes.hs +27/−0
- src/Matterhorn/Types.hs +2165/−2603
- src/Matterhorn/Types/Channels.hs +31/−126
- src/Matterhorn/Types/Core.hs +261/−0
- src/Matterhorn/Types/DirectionalSeq.hs +6/−0
- src/Matterhorn/Types/EditState.hs +270/−0
- src/Matterhorn/Types/KeyEvents.hs +8/−0
- src/Matterhorn/Types/MessageInterface.hs +127/−0
- src/Matterhorn/Types/Messages.hs +4/−25
- src/Matterhorn/Types/NonemptyStack.hs +51/−0
- src/Matterhorn/Types/Posts.hs +1/−1
- src/Matterhorn/Types/RichText.hs +8/−3
- src/Matterhorn/Types/TabbedWindow.hs +186/−0
- src/Matterhorn/Windows/ViewMessage.hs +12/−9
- test/Message_QCA.hs +1/−0
- test/test_messages.hs +1/−0
CHANGELOG.md view
@@ -1,4 +1,73 @@ +50200.17.0+==========++This release is mostly focused on adding support for a "thread window"+that allows you to carry on a conversation in a thread of your+choosing while also seeing, visiting, and switching between channels+simultaneously.++To use the thread window, select a message with `C-s` and then press+`t`. This binding can be customized by overriding the key binding for+the `open-thread` key event.++Once the thread window is open:+ * It can be closed with `Esc`.+ * The editor focus can be swapped between the thread window and the+ currently selected channel with `M-o` (the default binding for+ the key event `change-message-editor-focus`). The currently+ focused editor's prompt is highlighted when a thread window is+ open to help you spot the focused editor. The theme attribute+ `focusedEditorPrompt` can be customized to change the focused editor+ prompt style.+ * All of key bindings that work in a channel (such as `C-s`) work in a+ thread window, too.+ * As one would expect, in a thread window, all messages are implicitly+ part of the thread; no explicit `C-r` or `C-s`/`r` steps are needed+ to reply.+ * The thread window is per-team; you can have a thread window open even+ while you switch between channels to view other channels in the same+ team while still participating in a thread. Each team can have an+ open thread window for some thread in that team's channels.+ * The thread window's base attribute can be customized in your theme+ configuration file by setting the value of `thread`.+ * The thread window's orientation relative to the currently selected+ channel can be customized with either the `/thread-orientation`+ command or the `threadOrientation` configuration file setting. Both+ the command and config file setting can take one of the values+ `above`, `below`, `left`, or `right`.+ * By default, the thread window will not be re-opened next time+ Matterhorn is started. If you would like to make Matterhorn always+ re-open the last thread you had open on a per-team basis, you can set+ the new `showLastOpenThread` config file setting to `True`.++Other enhancements:+ * There is a new `/toggle-mouse-input` command to toggle whether mouse+ input is enabled at runtime.+ * Matterhorn now starts and uses only one instance of `aspell`. Prior+ to this release, Matterhorn started one instance of `aspell` per team.+ * The message text parser now properly recognizes usernames that are+ followed immediately by periods. Previously, something like "@user."+ at the end of a sentence would not cause "@user" to be highlighted+ as a user reference. With this fix, "@user" will be highlighted as+ long as it is not followed by more valid username text; if the period+ is followed by non-whitespace characters that are valid in usernames,+ the entire token will be treated as a username as expected, since+ usernames like "@user.blah" are valid Mattermost usernames.+ * Added additional default key bindings for the following key events:+ * `scroll-top`: `Meta-<`+ * `scroll-bottom`: `Meta->`+ * `filebrowser-list-top`: `Meta-<`+ * `filebrowser-list-bottom`: `Meta->`+ * The help screen's section on keybindings now displays the key event+ names for all rebindable keys. The theme attribute used to render the+ key event names is `helpKeyEvent`.++Bug fixes:+ * Fixed a bug where clickable links were not clickable outside of+ messages in some cases. This affected clickable links in channel+ topics.+ 50200.16.0 ========== @@ -20,7 +89,7 @@ * `unread-first` - same as default except that unread channels are displayed at the top of each group. * The channel list now displays a scroll bar and can be scrolled- independently of the selected channel with these key key events and+ independently of the selected channel with these key events and bindings: * `C-Up` / `channel-list-scroll-up` - Scroll up in the channel list * `C-Down` / `channel-list-scroll-down` - Scroll down in the channel@@ -40,7 +109,7 @@ * The new `/toggle-sidebar-group` command toggles the visibility of a specified channel list group. * The login interface got support for 2FA (second factor- authentication) support. The UI automatically asks for a second+ authentication). The UI automatically asks for a second factor if the server requires it. (Thanks msm@tailcall.net!) Other enhancements:
README.md view
@@ -67,6 +67,7 @@ * Optimized channel-switching modes: `M-a`, `M-s`, and `C-g` * Message posting, editing, replying, and deletion * Markdown rendering+* Support for participating in threads via the thread window * Convenient URL-opening with local browser * Secure password entry via external command (e.g. OSX keychain) * Secure authentication token entry via external command (e.g. OSX
docs/commands.md view
@@ -45,12 +45,14 @@ | `/shortcuts` | Show keyboard shortcuts | | `/theme` | List the available themes | | `/theme <theme>` | Set the color theme |+| `/thread-orientation <left\|right\|above\|below>` | Set the orientation of the thread UI | | `/toggle-channel-list` | Toggle channel list visibility | | `/toggle-expanded-topics` | Toggle expanded channel topics | | `/toggle-favorite` | Toggle the favorite status of the current channel | | `/toggle-message-timestamps` | Toggle message timestamps |+| `/toggle-mouse-input` | Toggle whether mouse input is enabled | | `/toggle-sidebar-group` | Toggle the visibility of the current channel's sidebar group |-| `/toggle-sidebar-group <public|private|favorite|direct>` | Toggle the visibility of the named sidebar group |+| `/toggle-sidebar-group <public\|private\|favorite\|direct>` | Toggle the visibility of the named sidebar group | | `/toggle-truncate-verbatim-blocks` | Toggle truncation of verbatim and code blocks | | `/topic` | Set the current channel's topic (header) interactively | | `/topic <topic>` | Set the current channel's topic (header) |
docs/keybindings.md view
@@ -19,39 +19,44 @@ | `Down` | `scroll-down` | Scroll down | | `PgUp` | `page-up` | Page up | | `PgDown` | `page-down` | Page down |-| `Esc`, `C-c` | `cancel` | Return to the previous interface |-| `End` | `scroll-bottom` | Scroll to the end of the help |-| `Home` | `scroll-top` | Scroll to the beginning of the help |+| `Esc`, `C-c` | `cancel` | Close the help window |+| `End`, `M->` | `scroll-bottom` | Scroll to the end of the help |+| `Home`, `M-<` | `scroll-top` | Scroll to the beginning of the help | # Main Interface | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- | | `F1` | `show-help` | Show this help screen |-| `C-s` | `select-mode` | Select a message to edit/reply/delete |-| `C-r` | `reply-recent` | Reply to the most recent message |-| `M-k` | `invoke-editor` | Invoke `$EDITOR` to edit the current message | | `C-g` | `enter-fast-select` | Enter fast channel selection mode |-| `Tab` | (non-customizable key) | Tab-complete forward |-| `BackTab` | (non-customizable key) | Tab-complete backward | | `C-Up` | `channel-list-scroll-up` | Scroll up in the channel list | | `C-Down` | `channel-list-scroll-down` | Scroll down in the channel list | | `F4` | `cycle-channel-list-sorting` | Cycle through channel list sorting modes |-| `Up` | `scroll-up` | Scroll up in the channel input history |-| `Down` | `scroll-down` | Scroll down in the channel input history |-| `PgUp` | `page-up` | Page up in the channel message list (enters message select mode) |-| `S-Home` | `select-oldest-message` | Scroll to top of channel message list |+| `C-r` | `reply-recent` | Reply to the most recent message |+| `M-o` | `change-message-editor-focus` | Cycle between message editors when a thread is open | | `C-n` | `focus-next-channel` | Change to the next channel in the channel list | | `C-p` | `focus-prev-channel` | Change to the previous channel in the channel list | | `M-a` | `focus-next-unread` | Change to the next channel with unread messages or return to the channel marked '~' |-| `C-x` | `show-attachment-list` | Show the attachment list | | (unbound) | `focus-next-unread-user-or-channel` | Change to the next channel with unread messages preferring direct messages | | `M-s` | `focus-last-channel` | Change to the most recently-focused channel |-| `Enter` | (non-customizable key) | Send the current message |-| `C-o` | `enter-url-open` | Select and open a URL posted to the current channel | | `M-l` | `clear-unread` | Clear the current channel's unread / edited indicators |+| `M-8` | `show-flagged-posts` | View currently flagged posts |+| `C-s` | `select-mode` | Select a message to edit/reply/delete |+| `PgUp` | `page-up` | Page up in the message list (enters message select mode) |+| `S-Home` | `select-oldest-message` | Scroll to top of message list |+| `C-o` | `enter-url-open` | Select and open a URL from the current message list |++# Message Editing+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- | | `M-e` | `toggle-multiline` | Toggle multi-line message compose mode | | `Esc`, `C-c` | `cancel` | Cancel autocomplete, message reply, or edit, in that order |-| `M-8` | `show-flagged-posts` | View currently flagged posts |+| `M-k` | `invoke-editor` | Invoke `$EDITOR` to edit the current message |+| `Tab` | (non-customizable key) | Tab-complete forward |+| `BackTab` | (non-customizable key) | Tab-complete backward |+| `C-x` | `show-attachment-list` | Show the attachment list |+| `Enter` | (non-customizable key) | Send the current message |+| `Up` | `scroll-up` | Scroll up in the channel input history |+| `Down` | `scroll-down` | Scroll down in the channel input history | # Text Editing | Keybinding | Event Name | Description |@@ -61,7 +66,6 @@ | `C-e` | `editor-end-of-line` | Go to the end of the current line | | `C-d` | `editor-delete-char` | Delete the character at the cursor | | `C-u` | `editor-kill-to-beginning-of-line` | Delete from the cursor to the start of the current line |-| `C-k` | `editor-kill-to-end-of-line` | Kill the line to the right of the current position and copy it | | `C-f` | `editor-next-char` | Move one character to the right | | `C-b` | `editor-prev-char` | Move one character to the left | | `M-f` | `editor-next-word` | Move one word to the right |@@ -70,6 +74,7 @@ | `M-d` | `editor-delete-next-word` | Delete the word to the right of the cursor | | `Home` | `editor-home` | Move the cursor to the beginning of the input | | `End` | `editor-end` | Move the cursor to the end of the input |+| `C-k` | `editor-kill-to-end-of-line` | Kill the line to the right of the current position and copy it | | `C-y` | `editor-yank` | Paste the current buffer contents at the cursor | # Channel Select Mode@@ -88,8 +93,8 @@ | `Esc`, `C-c` | `cancel` | Cancel message selection | | `k`, `Up` | `select-up` | Select the previous message | | `j`, `Down` | `select-down` | Select the next message |-| `Home` | `scroll-top` | Scroll to top and select the oldest message |-| `End` | `scroll-bottom` | Scroll to bottom and select the latest message |+| `Home`, `M-<` | `scroll-top` | Scroll to top and select the oldest message |+| `End`, `M->` | `scroll-bottom` | Scroll to bottom and select the latest message | | `PgUp` | `page-up` | Move the cursor up by 10 messages | | `PgDown` | `page-down` | Move the cursor down by 10 messages | | `o` | `open-message-url` | Open all URLs in the selected message |@@ -101,6 +106,7 @@ | `p` | `pin-message` | Toggle whether the selected message is pinned | | `f` | `flag-message` | Flag the selected message | | `v` | `view-message` | View the selected message |+| `t` | `open-thread` | Open the selected message's thread in a thread window | | `Enter` | `fetch-for-gap` | Fetch messages for the selected gap | | `a` | `react-to-message` | Post a reaction to the selected message | | `l` | `copy-post-link` | Copy a post's link to the clipboard |@@ -163,8 +169,8 @@ | `Down` | `scroll-down` | Scroll down | | `Left` | `scroll-left` | Scroll left | | `Right` | `scroll-right` | Scroll right |-| `End` | `scroll-bottom` | Scroll to the end of the message |-| `Home` | `scroll-top` | Scroll to the beginning of the message |+| `End`, `M->` | `scroll-bottom` | Scroll to the end of the message |+| `Home`, `M-<` | `scroll-top` | Scroll to the beginning of the message | # Message Viewer: Reactions tab | Keybinding | Event Name | Description |@@ -173,8 +179,8 @@ | `PgDown` | `page-down` | Page down | | `Up` | `scroll-up` | Scroll up | | `Down` | `scroll-down` | Scroll down |-| `End` | `scroll-bottom` | Scroll to the end of the reactions list |-| `Home` | `scroll-top` | Scroll to the beginning of the reactions list |+| `End`, `M->` | `scroll-bottom` | Scroll to the end of the reactions list |+| `Home`, `M-<` | `scroll-top` | Scroll to the beginning of the reactions list | # Attachment List | Keybinding | Event Name | Description |@@ -198,8 +204,8 @@ | `C-f`, `PgDown` | `filebrowser-list-page-down` | Move cursor one page down | | `C-u` | `filebrowser-list-half-page-up` | Move cursor one-half page up | | `C-d` | `filebrowser-list-half-page-down` | Move cursor one-half page down |-| `g`, `Home` | `filebrowser-list-top` | Move cursor to top of list |-| `G`, `End` | `filebrowser-list-bottom` | Move cursor to bottom of list |+| `g`, `Home`, `M-<` | `filebrowser-list-top` | Move cursor to top of list |+| `G`, `End`, `M->` | `filebrowser-list-bottom` | Move cursor to bottom of list | | `j`, `C-n`, `Down` | `filebrowser-list-next` | Move cursor down | | `k`, `C-p`, `Up` | `filebrowser-list-previous` | Move cursor up |
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.16.0+version: 50200.17.0 synopsis: Terminal client for the Mattermost chat system description: This is a terminal client for the Mattermost chat system. Please see the README for a list of@@ -54,30 +54,32 @@ Matterhorn.Draw.Autocomplete Matterhorn.Draw.Buttons Matterhorn.Draw.ChannelList- Matterhorn.Draw.ChannelListOverlay+ Matterhorn.Draw.ChannelListWindow+ Matterhorn.Draw.ChannelSelectPrompt Matterhorn.Draw.ChannelTopicWindow- Matterhorn.Draw.SaveAttachmentWindow Matterhorn.Draw.DeleteChannelConfirm+ Matterhorn.Draw.InputPreview Matterhorn.Draw.LeaveChannelConfirm- Matterhorn.Draw.ListOverlay+ Matterhorn.Draw.ListWindow Matterhorn.Draw.Main Matterhorn.Draw.ManageAttachments+ Matterhorn.Draw.MessageDeleteConfirm+ Matterhorn.Draw.MessageInterface Matterhorn.Draw.Messages Matterhorn.Draw.NotifyPrefs- Matterhorn.Draw.PostListOverlay- Matterhorn.Draw.ReactionEmojiListOverlay+ Matterhorn.Draw.PostListWindow+ Matterhorn.Draw.ReactionEmojiListWindow Matterhorn.Draw.RichText Matterhorn.Draw.RichText.Wrap Matterhorn.Draw.RichText.Flatten Matterhorn.Draw.ShowHelp Matterhorn.Draw.TabbedWindow- Matterhorn.Draw.ThemeListOverlay- Matterhorn.Draw.URLList- Matterhorn.Draw.UserListOverlay+ Matterhorn.Draw.ThemeListWindow+ Matterhorn.Draw.UserListWindow Matterhorn.Draw.Util Matterhorn.Emoji Matterhorn.Events- Matterhorn.Events.ChannelListOverlay+ Matterhorn.Events.ChannelListWindow Matterhorn.Events.ChannelSelect Matterhorn.Events.ChannelTopicWindow Matterhorn.Events.SaveAttachmentWindow@@ -89,14 +91,16 @@ Matterhorn.Events.Main Matterhorn.Events.ManageAttachments Matterhorn.Events.MessageSelect+ Matterhorn.Events.MessageInterface Matterhorn.Events.Mouse- Matterhorn.Events.PostListOverlay- Matterhorn.Events.ReactionEmojiListOverlay+ Matterhorn.Events.PostListWindow+ Matterhorn.Events.ReactionEmojiListWindow Matterhorn.Events.ShowHelp Matterhorn.Events.TabbedWindow- Matterhorn.Events.ThemeListOverlay+ Matterhorn.Events.ThemeListWindow+ Matterhorn.Events.ThreadWindow Matterhorn.Events.UrlSelect- Matterhorn.Events.UserListOverlay+ Matterhorn.Events.UserListWindow Matterhorn.Events.Websocket Matterhorn.FilePaths Matterhorn.HelpTopics@@ -111,7 +115,7 @@ Matterhorn.State.Attachments Matterhorn.State.Autocomplete Matterhorn.State.ChannelList- Matterhorn.State.ChannelListOverlay+ Matterhorn.State.ChannelListWindow Matterhorn.State.ChannelSelect Matterhorn.State.Channels Matterhorn.State.ChannelTopicWindow@@ -121,32 +125,38 @@ Matterhorn.State.Flagging Matterhorn.State.Help Matterhorn.State.Links- Matterhorn.State.ListOverlay+ Matterhorn.State.ListWindow Matterhorn.State.Logging Matterhorn.State.MessageSelect Matterhorn.State.Messages Matterhorn.State.NotifyPrefs- Matterhorn.State.PostListOverlay- Matterhorn.State.ReactionEmojiListOverlay+ Matterhorn.State.PostListWindow+ Matterhorn.State.ReactionEmojiListWindow Matterhorn.State.Reactions Matterhorn.State.Setup Matterhorn.State.Setup.Threads Matterhorn.State.Setup.Threads.Logging Matterhorn.State.Teams- Matterhorn.State.ThemeListOverlay+ Matterhorn.State.ThemeListWindow+ Matterhorn.State.ThreadWindow Matterhorn.State.UrlSelect- Matterhorn.State.UserListOverlay+ Matterhorn.State.UserListWindow Matterhorn.State.Users Matterhorn.Themes Matterhorn.TimeUtils Matterhorn.Types Matterhorn.Types.Channels Matterhorn.Types.Common+ Matterhorn.Types.Core Matterhorn.Types.DirectionalSeq+ Matterhorn.Types.EditState Matterhorn.Types.KeyEvents Matterhorn.Types.Messages+ Matterhorn.Types.MessageInterface+ Matterhorn.Types.NonemptyStack Matterhorn.Types.Posts Matterhorn.Types.RichText+ Matterhorn.Types.TabbedWindow Matterhorn.Types.Users Matterhorn.Util Matterhorn.Windows.ViewMessage@@ -161,7 +171,7 @@ ghc-options: -fhide-source-paths build-depends: base >=4.8 && <5- , mattermost-api == 50200.12.0+ , mattermost-api == 50200.13.0 , base-compat >= 0.9 && < 0.13 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7@@ -175,7 +185,7 @@ , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.5- , brick >= 0.68.1 && < 0.69+ , brick >= 0.70 && < 0.71 , brick-skylighting >= 0.2 && < 0.4 , vty >= 5.35 && < 5.36 , word-wrap >= 0.4.0 && < 0.5
src/Matterhorn/App.hs view
@@ -9,7 +9,6 @@ import Brick import Control.Monad.Trans.Except ( runExceptT )-import qualified Data.HashMap.Strict as HM import qualified Graphics.Vty as Vty import Text.Aspell ( stopAspell ) import GHC.Conc (getNumProcessors, setNumCapabilities)@@ -30,37 +29,43 @@ app :: App ChatState MHEvent Name-app = App- { appDraw = draw- , appChooseCursor = \s cs ->- case s^.csCurrentTeamId of- Nothing -> showFirstCursor s cs- Just tId ->- case s^.csTeam(tId).tsMode of- Main -> showFirstCursor s cs- ChannelSelect -> showFirstCursor s cs- UserListOverlay -> showFirstCursor s cs- ReactionEmojiListOverlay -> showFirstCursor s cs- ChannelListOverlay -> showFirstCursor s cs- ManageAttachmentsBrowseFiles -> showFirstCursor s cs- ThemeListOverlay -> showFirstCursor s cs- ChannelTopicWindow -> showCursorNamed (ChannelTopicEditor tId) cs- SaveAttachmentWindow _ -> showCursorNamed (AttachmentPathEditor tId) cs- LeaveChannelConfirm -> Nothing- DeleteChannelConfirm -> Nothing- MessageSelect -> Nothing- MessageSelectDeleteConfirm -> Nothing- PostListOverlay _ -> Nothing- ManageAttachments -> Nothing- ViewMessage -> Nothing- ShowHelp _ _ -> Nothing- UrlSelect -> Nothing- EditNotifyPrefs -> Nothing- , appHandleEvent = Events.onEvent- , appStartEvent = return- , appAttrMap = (^.csResources.crTheme)- }+app =+ App { appDraw = draw+ , appHandleEvent = Events.onEvent+ , appStartEvent = return+ , appAttrMap = (^.csResources.crTheme)+ , appChooseCursor = \s cs -> do+ tId <- s^.csCurrentTeamId+ cursorByMode cs s tId (teamMode $ s^.csTeam(tId))+ } +cursorByMode :: [CursorLocation Name] -> ChatState -> TeamId -> Mode -> Maybe (CursorLocation Name)+cursorByMode cs s tId mode =+ case mode of+ Main -> case s^.csTeam(tId).tsMessageInterfaceFocus of+ FocusCurrentChannel -> do+ cId <- s^.csCurrentChannelId(tId)+ mi <- s^?maybeChannelMessageInterface(cId)+ cur <- messageInterfaceCursor mi+ showCursorNamed cur cs+ FocusThread -> do+ ti <- s^.csTeam(tId).tsThreadInterface+ cur <- messageInterfaceCursor ti+ showCursorNamed cur cs+ LeaveChannelConfirm -> Nothing+ DeleteChannelConfirm -> Nothing+ MessageSelectDeleteConfirm {} -> Nothing+ (PostListWindow {}) -> Nothing+ ViewMessage -> Nothing+ (ShowHelp {}) -> Nothing+ EditNotifyPrefs -> Nothing+ ChannelSelect -> showFirstCursor s cs+ UserListWindow -> showFirstCursor s cs+ ReactionEmojiListWindow -> showFirstCursor s cs+ ChannelListWindow -> showFirstCursor s cs+ ThemeListWindow -> showFirstCursor s cs+ ChannelTopicWindow -> showCursorNamed (ChannelTopicEditor tId) cs+ applicationMaxCPUs :: Int applicationMaxCPUs = 2 @@ -94,10 +99,9 @@ (st, vty) <- setupState mkVty (optLogLocation opts) config finalSt <- customMain vty mkVty (Just $ st^.csResources.crEventQueue) app st - forM_ (HM.elems $ finalSt^.csTeams) $ \ts ->- case ts^.tsEditState.cedSpellChecker of- Nothing -> return ()- Just (s, _) -> stopAspell s+ case st^.csResources.crSpellChecker of+ Nothing -> return ()+ Just s -> stopAspell s return finalSt
src/Matterhorn/Command.hs view
@@ -32,14 +32,14 @@ import Matterhorn.State.Channels import Matterhorn.State.ChannelTopicWindow import Matterhorn.State.ChannelSelect+import Matterhorn.State.Common import Matterhorn.State.Logging-import Matterhorn.State.PostListOverlay-import Matterhorn.State.UserListOverlay-import Matterhorn.State.ChannelListOverlay-import Matterhorn.State.ThemeListOverlay+import Matterhorn.State.PostListWindow+import Matterhorn.State.UserListWindow+import Matterhorn.State.ChannelListWindow+import Matterhorn.State.ThemeListWindow import Matterhorn.State.Messages import Matterhorn.State.NotifyPrefs-import Matterhorn.State.Common ( postInfoMessage ) import Matterhorn.State.Teams import Matterhorn.State.Users import Matterhorn.Themes ( attrForUsername )@@ -137,7 +137,7 @@ withCurrentTeam startLeaveCurrentChannel , Cmd "join" "Find a channel to join" NoArg $ \ () -> do- withCurrentTeam enterChannelListOverlayMode+ withCurrentTeam enterChannelListWindowMode , Cmd "join" "Join the specified channel" (ChannelArg NoArg) $ \(n, ()) -> do withCurrentTeam $ \tId ->@@ -182,8 +182,9 @@ withCurrentTeam $ \tId -> withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do case foundUser of- Just user -> createOrFocusDMChannel tId user $ Just $ \cId -> do- handleInputSubmission tId cId msg+ Just user -> createOrFocusDMChannel tId user $ Just $ \_ -> do+ withCurrentChannel tId $ \cId _ ->+ handleInputSubmission (channelEditor(cId)) msg Nothing -> mhError $ NoSuchUser name , Cmd "log-start" "Begin logging debug information to the specified path"@@ -240,6 +241,9 @@ , Cmd "cycle-channel-list-sorting" "Cycle through channel list sorting modes for this team" NoArg $ \_ -> withCurrentTeam cycleChannelListSortingMode + , Cmd "thread-orientation" "Set the orientation of the thread UI" (LineArg "left|right|above|below") $ \o ->+ setThreadOrientationByName o+ , Cmd "focus" "Focus on a channel or user" (ChannelArg NoArg) $ \ (name, ()) -> do withCurrentTeam $ \tId ->@@ -275,7 +279,7 @@ (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do withCurrentTeam $ \tId -> withCurrentChannel tId $ \cId _ -> do- findAndRunScript tId cId script text+ findAndRunScript (channelEditor(cId)) script text , Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () -> do withCurrentTeam enterFlaggedPostListMode@@ -301,9 +305,18 @@ moveCurrentTeamRight , Cmd "attach" "Attach a given file without browsing" (LineArg "path") $ \path -> do- withCurrentTeam $ \tId ->- attachFileByPath tId path+ withCurrentTeam $ \tId -> do+ foc <- use (csTeam(tId).tsMessageInterfaceFocus)+ case foc of+ FocusThread ->+ attachFileByPath (unsafeThreadInterface(tId)) path+ FocusCurrentChannel ->+ withCurrentChannel tId $ \cId _ ->+ attachFileByPath (csChannelMessageInterface(cId)) path + , Cmd "toggle-mouse-input" "Toggle whether mouse input is enabled" NoArg $ \_ ->+ toggleMouseMode+ , Cmd "toggle-favorite" "Toggle the favorite status of the current channel" NoArg $ \_ -> do withCurrentTeam toggleChannelFavoriteStatus @@ -326,7 +339,7 @@ execMMCommand tId name rest = do withCurrentChannel tId $ \cId _ -> do session <- getSession- em <- use (csTeam(tId).tsEditState.cedEditMode)+ em <- use (channelEditor(cId).esEditMode) let mc = MM.MinCommand { MM.minComChannelId = cId , MM.minComCommand = "/" <> name <> " " <> rest
src/Matterhorn/Command.hs-boot view
@@ -1,6 +1,7 @@ module Matterhorn.Command where -import Data.Text ( Text )+import Prelude ()+import Matterhorn.Prelude import Network.Mattermost.Types ( TeamId ) import Matterhorn.Types ( MH, Cmd, CmdArgs )
src/Matterhorn/Config.hs view
@@ -129,12 +129,17 @@ | otherwise -> Just i configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs" (configHyperlinkingMode defaultConfig)+ configShowLastOpenThread <- fieldFlagDef "showLastOpenThread"+ (configShowLastOpenThread defaultConfig) configPass <- (Just . PasswordCommand <$> field "passcmd") <!> (Just . PasswordString <$> field "pass") <!> pure Nothing configChannelListOrientation <- fieldDefOf "channelListOrientation" channelListOrientationField (configChannelListOrientation defaultConfig)+ configThreadOrientation <- fieldDefOf "threadOrientation"+ threadOrientationField+ (configThreadOrientation defaultConfig) configToken <- (Just . TokenCommand <$> field "tokencmd") <!> pure Nothing configUnsafeUseHTTP <-@@ -165,6 +170,15 @@ "right" -> return ChannelListRight _ -> Left $ "Invalid value for channelListOrientation: " <> show t +threadOrientationField :: Text -> Either String ThreadOrientation+threadOrientationField t =+ case T.toLower t of+ "left" -> return ThreadLeft+ "right" -> return ThreadRight+ "above" -> return ThreadAbove+ "below" -> return ThreadBelow+ _ -> Left $ "Invalid value for threadOrientation: " <> show t+ syntaxDirsField :: Text -> Either String [FilePath] syntaxDirsField = listWithSeparator ":" string @@ -297,11 +311,13 @@ , configShowTypingIndicator = False , configSendTypingNotifications = False , configHyperlinkingMode = True+ , configShowLastOpenThread = False , configSyntaxDirs = [] , configDirectChannelExpirationDays = 7 , configCpuUsagePolicy = MultipleCPUs , configDefaultAttachmentPath = Nothing , configChannelListOrientation = ChannelListLeft+ , configThreadOrientation = ThreadBelow , configMouseMode = False , configChannelListSorting = ChannelListSortDefault }
src/Matterhorn/Draw.hs view
@@ -10,50 +10,57 @@ import Lens.Micro.Platform ( _2, singular, _Just ) import Matterhorn.Draw.ChannelTopicWindow-import Matterhorn.Draw.SaveAttachmentWindow+import Matterhorn.Draw.ChannelSelectPrompt+import Matterhorn.Draw.MessageDeleteConfirm import Matterhorn.Draw.DeleteChannelConfirm import Matterhorn.Draw.LeaveChannelConfirm import Matterhorn.Draw.Main-import Matterhorn.Draw.ThemeListOverlay-import Matterhorn.Draw.PostListOverlay+import Matterhorn.Draw.ThemeListWindow+import Matterhorn.Draw.PostListWindow import Matterhorn.Draw.ShowHelp-import Matterhorn.Draw.UserListOverlay-import Matterhorn.Draw.ChannelListOverlay-import Matterhorn.Draw.ReactionEmojiListOverlay+import Matterhorn.Draw.UserListWindow+import Matterhorn.Draw.ChannelListWindow+import Matterhorn.Draw.ReactionEmojiListWindow import Matterhorn.Draw.TabbedWindow-import Matterhorn.Draw.ManageAttachments import Matterhorn.Draw.NotifyPrefs import Matterhorn.Types draw :: ChatState -> [Widget Name]-draw st =- let mainLayers = drawMain True st- mainLayersMonochrome = drawMain False st- in case st^.csCurrentTeamId of- Nothing ->- -- ^ Without a team data structure, we just assume Main mode- -- and render a skeletal UI.- mainLayers- Just tId ->- let messageViewWindow = st^.csTeam(tId).tsViewedMessage.singular _Just._2- in case st^.csTeam(tId).tsMode of- Main -> mainLayers- UrlSelect -> mainLayers- ChannelSelect -> mainLayers- MessageSelect -> mainLayers- MessageSelectDeleteConfirm -> mainLayers- ShowHelp topic _ -> drawShowHelp topic st- ThemeListOverlay -> drawThemeListOverlay st tId : mainLayers- LeaveChannelConfirm -> drawLeaveChannelConfirm st tId : mainLayersMonochrome- DeleteChannelConfirm -> drawDeleteChannelConfirm st tId : mainLayersMonochrome- PostListOverlay contents -> drawPostListOverlay contents st tId : mainLayersMonochrome- UserListOverlay -> drawUserListOverlay st tId : mainLayersMonochrome- ChannelListOverlay -> drawChannelListOverlay st tId : mainLayersMonochrome- ReactionEmojiListOverlay -> drawReactionEmojiListOverlay st tId : mainLayersMonochrome- ViewMessage -> drawTabbedWindow messageViewWindow st tId : mainLayersMonochrome- ManageAttachments -> drawManageAttachments st tId : mainLayersMonochrome- ManageAttachmentsBrowseFiles -> drawManageAttachments st tId : mainLayersMonochrome- EditNotifyPrefs -> drawNotifyPrefs st tId : mainLayersMonochrome- ChannelTopicWindow -> drawChannelTopicWindow st tId : mainLayersMonochrome- SaveAttachmentWindow _ -> drawSaveAttachmentWindow st tId : mainLayersMonochrome+draw st = fromMaybe (drawMain st Main) $ do+ tId <- st^.csCurrentTeamId+ let messageViewWindow = st^.csTeam(tId).tsViewedMessage.singular _Just._2+ monochrome = fmap (forceAttr "invalid")+ drawMode m ms =+ let rest = case ms of+ (a:as) -> drawMode a as+ _ -> []+ in case m of+ -- For this first section of modes, we only want+ -- to draw for the current mode and ignore the+ -- mode stack because we expect the current mode+ -- to be all we need to draw what should be on+ -- the screen.+ Main -> drawMain st m+ ShowHelp topic -> drawShowHelp topic st++ -- For the following modes, we want to draw the+ -- whole mode stack since we expect the UI to+ -- have layers and we want to show prior modes+ -- underneath.+ ChannelSelect -> drawChannelSelectPrompt st tId : drawMain st m+ MessageSelectDeleteConfirm {} -> drawMessageDeleteConfirm : rest+ ThemeListWindow -> drawThemeListWindow st tId : rest+ LeaveChannelConfirm -> drawLeaveChannelConfirm st tId : monochrome rest+ DeleteChannelConfirm -> drawDeleteChannelConfirm st tId : monochrome rest+ PostListWindow contents -> drawPostListWindow contents st tId : monochrome rest+ UserListWindow -> drawUserListWindow st tId : monochrome rest+ ChannelListWindow -> drawChannelListWindow st tId : monochrome rest+ ReactionEmojiListWindow -> drawReactionEmojiListWindow st tId : monochrome rest+ ViewMessage -> drawTabbedWindow messageViewWindow st tId : monochrome rest+ EditNotifyPrefs -> drawNotifyPrefs st tId : monochrome rest+ ChannelTopicWindow -> drawChannelTopicWindow st tId : monochrome rest+ topMode = teamMode $ st^.csTeam(tId)+ otherModes = tail $ teamModes $ st^.csTeam(tId)++ return $ drawMode topMode otherModes
src/Matterhorn/Draw/Autocomplete.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.Draw.Autocomplete- ( autocompleteLayer+ ( drawAutocompleteLayers ) where @@ -12,23 +13,45 @@ , listSelectedElement ) import qualified Data.Text as T+import Lens.Micro.Platform ( SimpleGetter, Lens' ) import Network.Mattermost.Types ( User(..), Channel(..), TeamId ) import Matterhorn.Constants ( normalChannelSigil )-import Matterhorn.Draw.Util+import Matterhorn.Draw.Util ( mkChannelName ) import Matterhorn.Themes import Matterhorn.Types import Matterhorn.Types.Common ( sanitizeUserText ) +drawAutocompleteLayers :: ChatState -> [Widget Name]+drawAutocompleteLayers st =+ catMaybes [ do+ tId <- st^.csCurrentTeamId+ cId <- st^.csCurrentChannelId(tId)+ return $ autocompleteLayer st (channelEditor(cId))+ , do+ tId <- st^.csCurrentTeamId+ void $ st^.csTeam(tId).tsThreadInterface+ let ti :: Lens' ChatState ThreadInterface+ ti = unsafeThreadInterface(tId)+ ed :: SimpleGetter ChatState (EditState Name)+ ed = ti.miEditor+ return $ autocompleteLayer st ed+ ] -autocompleteLayer :: ChatState -> TeamId -> Widget Name-autocompleteLayer st tId =- case st^.csTeam(tId).tsEditState.cedAutocomplete of+autocompleteLayer :: ChatState -> SimpleGetter ChatState (EditState Name) -> Widget Name+autocompleteLayer st which =+ case st^.which.esAutocomplete of Nothing -> emptyWidget Just ac ->- renderAutocompleteBox st tId ac+ fromMaybe emptyWidget $ do+ tId <- st^.csCurrentTeamId+ let mcId = st^.csCurrentChannelId(tId)+ mCurChan = do+ cId <- mcId+ st^?csChannel(cId)+ return $ renderAutocompleteBox st tId mCurChan which ac userNotInChannelMarker :: T.Text userNotInChannelMarker = "*"@@ -40,63 +63,91 @@ elementTypeLabel ACEmoji = "Emoji" elementTypeLabel ACCommands = "Commands" -renderAutocompleteBox :: ChatState -> TeamId -> AutocompleteState -> Widget Name-renderAutocompleteBox st tId ac =+renderAutocompleteBox :: ChatState+ -> TeamId+ -> Maybe ClientChannel+ -> SimpleGetter ChatState (EditState Name)+ -> AutocompleteState Name+ -> Widget Name+renderAutocompleteBox st tId mCurChan which ac = let matchList = _acCompletionList ac maxListHeight = 5 visibleHeight = min maxListHeight numResults numResults = length elements elements = matchList^.listElementsL+ editorName = getName $ st^.which.esEditor+ isMultiline = st^.which.esEphemeral.eesMultiline label = withDefAttr clientMessageAttr $ txt $ elementTypeLabel (ac^.acType) <> ": " <> (T.pack $ show numResults) <> " match" <> (if numResults == 1 then "" else "es") <> " (Tab/Shift-Tab to select)" selElem = snd <$> listSelectedElement matchList- mcId = st^.csCurrentChannelId(tId)- mCurChan = mcId >>= (\cId -> st^?csChannel(cId)) footer = case mCurChan of Nothing -> hBorder Just curChan ->- case renderAutocompleteFooterFor curChan =<< selElem of+ case renderAutocompleteFooterFor st curChan =<< selElem of Just w -> hBorderWithLabel w _ -> hBorder curUser = myUsername st+ cfg = st^.csResources.crConfiguration+ showingChanList = configShowChannelList cfg+ chanListWidth = configChannelListWidth cfg+ maybeLimit = fromMaybe id $ do+ let sub = if showingChanList+ then chanListWidth + 1+ else 0+ threadNarrow = threadShowing && (cfg^.configThreadOrientationL `elem` [ThreadLeft, ThreadRight])+ threadShowing = isJust $ st^.csTeam(tId).tsThreadInterface + if threadNarrow || sub > 0+ then return $ \w -> Widget Greedy Greedy $ do+ ctx <- getContext+ let adjusted = ctx^.availWidthL - sub+ lim = if threadNarrow+ then (adjusted - 1) `div` 2+ else adjusted+ render $ hLimit lim w+ else Nothing++ -- The top left corner of the editor area is given by the+ -- prompt, or by the editor position if multiline is enabled (in+ -- which case no prompt is drawn).+ editorTop = if isMultiline+ then editorName+ else MessageInputPrompt editorName+ in if numResults == 0 then emptyWidget else Widget Greedy Greedy $ do- ctx <- getContext- let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight- editorOffset = if st^.csTeam(tId).tsEditState.cedEphemeral.eesMultiline- then multilineHeightLimit- else 0- render $ translateBy (Location (0, rowOffset)) $+ let verticalOffset = -1 * (visibleHeight + 2)+ render $ relativeTo editorTop (Location (0, verticalOffset)) $+ maybeLimit $ vBox [ hBorderWithLabel label , vLimit visibleHeight $ renderList (renderAutocompleteAlternative curUser) True matchList , footer ] -renderAutocompleteFooterFor :: ClientChannel -> AutocompleteAlternative -> Maybe (Widget Name)-renderAutocompleteFooterFor _ (SpecialMention MentionChannel) = Nothing-renderAutocompleteFooterFor _ (SpecialMention MentionAll) = Nothing-renderAutocompleteFooterFor ch (UserCompletion _ False) =+renderAutocompleteFooterFor :: ChatState -> ClientChannel -> AutocompleteAlternative -> Maybe (Widget Name)+renderAutocompleteFooterFor _ _ (SpecialMention MentionChannel) = Nothing+renderAutocompleteFooterFor _ _ (SpecialMention MentionAll) = Nothing+renderAutocompleteFooterFor st ch (UserCompletion _ False) = Just $ hBox [ txt $ "(" , withDefAttr clientEmphAttr (txt userNotInChannelMarker) , txt ": not a member of "- , withDefAttr channelNameAttr (txt $ normalChannelSigil <> ch^.ccInfo.cdName)+ , withDefAttr channelNameAttr (txt $ mkChannelName st (ch^.ccInfo)) , txt ")" ]-renderAutocompleteFooterFor _ (ChannelCompletion False ch) =+renderAutocompleteFooterFor _ _ (ChannelCompletion False ch) = Just $ hBox [ txt $ "(" , withDefAttr clientEmphAttr (txt userNotInChannelMarker) , txt ": you are not a member of "- , withDefAttr channelNameAttr (txt $ normalChannelSigil <> sanitizeUserText (channelName ch))+ , withDefAttr channelNameAttr (txt $ normalChannelSigil <> preferredChannelName ch) , txt ")" ]-renderAutocompleteFooterFor _ (CommandCompletion src _ _ _) =+renderAutocompleteFooterFor _ _ (CommandCompletion src _ _ _) = case src of Server -> Just $ hBox [ txt $ "("@@ -104,7 +155,7 @@ , txt ": command provided by the server)" ] Client -> Nothing-renderAutocompleteFooterFor _ _ =+renderAutocompleteFooterFor _ _ _ = Nothing serverCommandMarker :: Text
src/Matterhorn/Draw/ChannelList.hs view
@@ -24,7 +24,9 @@ import Brick import Brick.Widgets.Border import Brick.Widgets.Center (hCenter)+import Brick.Widgets.Edit ( editContentsL ) import qualified Data.Text as T+import qualified Data.Text.Zipper as TZ import Data.Maybe ( fromJust ) import Lens.Micro.Platform (non) @@ -94,8 +96,8 @@ withVScrollBars sbOrientation $ withVScrollBarHandles $ withClickableVScrollBars VScrollBar $- viewport (ChannelList tId) Vertical $ sbPad body- body = case st^.csTeam(tId).tsMode of+ viewport (ChannelListViewport tId) Vertical $ sbPad body+ body = case teamMode $ st^.csTeam(tId) of ChannelSelect -> let zipper = st^.csTeam(tId).tsChannelSelectState.channelSelectMatches matches = if Z.isEmpty zipper@@ -182,12 +184,14 @@ prevEditSigil = "»" sigil = if current then fromMaybe "" normalSigil- else case chan^.ccEditState.eesInputHistoryPosition of+ else case chan^.ccMessageInterface.miEditor.esEphemeral.eesInputHistoryPosition of Just _ -> prevEditSigil Nothing ->- case chan^.ccEditState.eesLastInput of- ("", _) -> fromMaybe "" normalSigil- _ -> prevEditSigil+ let emptyEditor = T.null $ T.concat $ TZ.getText $+ chan^.ccMessageInterface.miEditor.esEditor.editContentsL+ in if emptyEditor+ then fromMaybe "" normalSigil+ else prevEditSigil mentions = chan^.ccInfo.cdMentionCount -- | Render an individual Channel List entry (in Normal mode) with@@ -228,7 +232,7 @@ | entryHasUnread entryData -> withDefAttr unreadChannelAttr | otherwise -> id- in clickable (ChannelSelectEntry match) $+ in clickable (ClickableChannelSelectEntry match) $ decorate $ maybeSelect $ decorateEntry entryData $ decorateMentions entryData $ padRight Max $
− src/Matterhorn/Draw/ChannelListOverlay.hs
@@ -1,53 +0,0 @@-module Matterhorn.Draw.ChannelListOverlay- ( drawChannelListOverlay- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import qualified Data.Text as T-import Text.Wrap ( defaultWrapSettings, preserveIndentation )--import Network.Mattermost.Types-import Network.Mattermost.Lenses--import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import Matterhorn.Types-import Matterhorn.Types.Common ( sanitizeUserText )-import Matterhorn.Themes---drawChannelListOverlay :: ChatState -> TeamId -> Widget Name-drawChannelListOverlay st tId =- let overlay = drawListOverlay (st^.csTeam(tId).tsChannelListOverlay) channelSearchScopeHeader- channelSearchScopeNoResults channelSearchScopePrompt- renderChannel- Nothing- OverlayCenter- 80- in joinBorders overlay--channelSearchScopePrompt :: ChannelSearchScope -> Widget Name-channelSearchScopePrompt scope =- txt $ case scope of- AllChannels -> "Search channels:"--channelSearchScopeNoResults :: ChannelSearchScope -> Widget Name-channelSearchScopeNoResults scope =- txt $ case scope of- AllChannels -> "No matching channels found."--channelSearchScopeHeader :: ChannelSearchScope -> Widget Name-channelSearchScopeHeader scope =- withDefAttr clientEmphAttr $ txt $ case scope of- AllChannels -> "Join a Channel"--renderChannel :: Bool -> Channel -> Widget Name-renderChannel _ chan =- let baseStr = (sanitizeUserText $ chan^.channelDisplayNameL) <>- " (" <> (sanitizeUserText $ chan^.channelNameL) <> ")"- s = " " <> (T.strip $ sanitizeUserText $ chan^.channelPurposeL)- in (vLimit 1 $ padRight Max $ withDefAttr clientEmphAttr $ txt baseStr) <=>- (vLimit 1 $ txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s)
+ src/Matterhorn/Draw/ChannelListWindow.hs view
@@ -0,0 +1,53 @@+module Matterhorn.Draw.ChannelListWindow+ ( drawChannelListWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import qualified Data.Text as T+import Text.Wrap ( defaultWrapSettings, preserveIndentation )++import Network.Mattermost.Types+import Network.Mattermost.Lenses++import Matterhorn.Draw.ListWindow ( drawListWindow, WindowPosition(..) )+import Matterhorn.Types+import Matterhorn.Types.Common ( sanitizeUserText )+import Matterhorn.Themes+++drawChannelListWindow :: ChatState -> TeamId -> Widget Name+drawChannelListWindow st tId =+ let window = drawListWindow (st^.csTeam(tId).tsChannelListWindow) channelSearchScopeHeader+ channelSearchScopeNoResults channelSearchScopePrompt+ renderChannel+ Nothing+ WindowCenter+ 80+ in joinBorders window++channelSearchScopePrompt :: ChannelSearchScope -> Widget Name+channelSearchScopePrompt scope =+ txt $ case scope of+ AllChannels -> "Search channels:"++channelSearchScopeNoResults :: ChannelSearchScope -> Widget Name+channelSearchScopeNoResults scope =+ txt $ case scope of+ AllChannels -> "No matching channels found."++channelSearchScopeHeader :: ChannelSearchScope -> Widget Name+channelSearchScopeHeader scope =+ withDefAttr clientEmphAttr $ txt $ case scope of+ AllChannels -> "Join a Channel"++renderChannel :: Bool -> Channel -> Widget Name+renderChannel _ chan =+ let baseStr = (sanitizeUserText $ chan^.channelDisplayNameL) <>+ " (" <> (sanitizeUserText $ chan^.channelNameL) <> ")"+ s = " " <> (T.strip $ sanitizeUserText $ chan^.channelPurposeL)+ in (vLimit 1 $ padRight Max $ withDefAttr clientEmphAttr $ txt baseStr) <=>+ (vLimit 1 $ txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s)
+ src/Matterhorn/Draw/ChannelSelectPrompt.hs view
@@ -0,0 +1,28 @@+module Matterhorn.Draw.ChannelSelectPrompt+ ( drawChannelSelectPrompt+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Edit ( renderEditor )+import qualified Data.Text as T+import Network.Mattermost.Types ( TeamId)++import Matterhorn.Types+import Matterhorn.Themes+++drawChannelSelectPrompt :: ChatState -> TeamId -> Widget Name+drawChannelSelectPrompt st tId =+ Widget Greedy Greedy $ do+ ctx <- getContext+ let rowOffset = ctx^.availHeightL - 1+ e = st^.csTeam(tId).tsChannelSelectState.channelSelectInput+ render $ translateBy (Location (0, rowOffset)) $+ withDefAttr channelSelectPromptAttr $+ (txt "Switch to channel [use ^ and $ to anchor]: ") <+>+ (renderEditor (txt . T.concat) True e)+
+ src/Matterhorn/Draw/InputPreview.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE RankNTypes #-}+module Matterhorn.Draw.InputPreview+ ( inputPreview+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Edit+import Control.Arrow ( (>>>) )+import qualified Data.Text as T+import Data.Text.Zipper ( insertChar, getText, gotoEOL )+import Data.Time.Calendar ( fromGregorian )+import Data.Time.Clock ( UTCTime(..) )+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( SimpleGetter, to )++import Network.Mattermost.Types ( ServerTime(..), UserId, TeamId+ )++import Matterhorn.Constants+import Matterhorn.Draw.Messages+import Matterhorn.Draw.RichText+import Matterhorn.Themes+import Matterhorn.Types+import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL )+++inputPreview :: ChatState+ -> SimpleGetter ChatState (EditState Name)+ -> TeamId+ -> Name+ -> HighlightSet+ -> Widget Name+inputPreview st editWhich tId vpName hs+ | not $ st^.csResources.crConfiguration.configShowMessagePreviewL = emptyWidget+ | otherwise = thePreview+ where+ uId = myUserId st+ -- Insert a cursor sentinel into the input text just before+ -- rendering the preview. We use the inserted sentinel (which is+ -- not rendered) to get brick to ensure that the line the cursor is+ -- on is visible in the preview viewport. We put the sentinel at+ -- the *end* of the line because it will still influence markdown+ -- parsing and can create undesirable/confusing churn in the+ -- rendering while the cursor moves around. If the cursor is at the+ -- end of whatever line the user is editing, that is very unlikely+ -- to be a problem.+ curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $+ st^.editWhich.esEditor.editContentsL+ eName = getName $ st^.editWhich.esEditor+ curStr = T.intercalate "\n" curContents+ overrideTy = case st^.editWhich.esEditMode of+ Editing _ ty -> Just ty+ _ -> Nothing+ baseUrl = serverBaseUrl st tId+ previewMsg = previewFromInput baseUrl overrideTy uId curStr+ thePreview = let noPreview = str "(No preview)"+ msgPreview = case previewMsg of+ Nothing -> noPreview+ Just pm -> if T.null curStr+ then noPreview+ else prview pm $ getParentMessage st pm+ tag = MessagePreviewViewport eName+ prview m p = freezeBorders $+ renderMessage MessageData+ { mdMessage = m+ , mdUserName = m^.mUser.to (printableNameForUserRef st)+ , mdParentMessage = p+ , mdParentUserName = p >>= (^.mUser.to (printableNameForUserRef st))+ , mdHighlightSet = hs+ , mdEditThreshold = Nothing+ , mdShowOlderEdits = False+ , mdRenderReplyParent = True+ , mdRenderReplyIndent = True+ , mdIndentBlocks = True+ , mdThreadState = NoThread+ , mdShowReactions = True+ , mdMessageWidthLimit = Nothing+ , mdMyUsername = myUsername st+ , mdMyUserId = myUserId st+ , mdWrapNonhighlightedCodeBlocks = True+ , mdTruncateVerbatimBlocks = Nothing+ , mdClickableNameTag = tag+ }+ in (maybePreviewViewport vpName msgPreview) <=>+ hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")++previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message+previewFromInput _ _ _ s | s == T.singleton cursorSentinel = Nothing+previewFromInput baseUrl overrideTy uId s =+ -- If it starts with a slash but not /me, this has no preview+ -- representation+ let isCommand = "/" `T.isPrefixOf` s+ isEmoteCmd = "/me " `T.isPrefixOf` s+ content = if isEmoteCmd+ then T.stripStart $ T.drop 3 s+ else s+ msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy+ in if isCommand && not isEmoteCmd+ then Nothing+ else Just $ Message { _mText = parseMarkdown (Just baseUrl) content+ , _mMarkdownSource = content+ , _mUser = UserI False uId+ , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0+ -- The date is not used for preview+ -- rendering, but we need to provide one.+ -- Ideally we'd just use today's date, but+ -- the rendering function is pure so we+ -- can't.+ , _mType = msgTy+ , _mPending = False+ , _mDeleted = False+ , _mAttachments = mempty+ , _mInReplyToMsg = NotAReply+ , _mMessageId = Nothing+ , _mReactions = mempty+ , _mOriginalPost = Nothing+ , _mFlagged = False+ , _mPinned = False+ , _mChannelId = Nothing+ }++maybePreviewViewport :: Name -> Widget Name -> Widget Name+maybePreviewViewport n w =+ Widget Greedy Fixed $ do+ result <- render w+ case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of+ False -> return result+ True ->+ render $ vLimit previewMaxHeight $ viewport n Vertical $+ (resultToWidget result)
− src/Matterhorn/Draw/ListOverlay.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Matterhorn.Draw.ListOverlay- ( drawListOverlay- , OverlayPosition(..)- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center-import Brick.Widgets.Edit-import qualified Brick.Widgets.List as L-import Control.Monad.Trans.Reader ( withReaderT )-import qualified Data.Foldable as F-import qualified Data.Text as T-import Graphics.Vty ( imageWidth, translateX)-import Lens.Micro.Platform ( (%~), (.~), to )--import Matterhorn.Themes-import Matterhorn.Types---hLimitWithPadding :: Int -> Widget n -> Widget n-hLimitWithPadding pad contents = Widget- { hSize = Fixed- , vSize = (vSize contents)- , render =- withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents- }--data OverlayPosition =- OverlayCenter- | OverlayUpperRight- deriving (Eq, Show)---- | Draw a ListOverlayState. This draws a bordered box with the--- overlay's search input and results list inside the box. The provided--- functions determine how to render the overlay in various states.-drawListOverlay :: ListOverlayState a b- -- ^ The overlay state- -> (b -> Widget Name)- -- ^ The function to build the window title from the- -- current search scope- -> (b -> Widget Name)- -- ^ The function to generate a message for the search- -- scope indicating that no results were found- -> (b -> Widget Name)- -- ^ The function to generate the editor prompt for the- -- search scope- -> (Bool -> a -> Widget Name)- -- ^ The function to render an item from the overlay's- -- list- -> Maybe (Widget Name)- -- ^ The footer widget to render underneath the search- -- results- -> OverlayPosition- -- ^ How to position the overlay layer- -> Int- -- ^ The maximum window width in columns- -> Widget Name-drawListOverlay st scopeHeader scopeNoResults scopePrompt renderItem footer layerPos maxWinWidth =- positionLayer $ hLimitWithPadding 10 $ vLimit 25 $- hLimit maxWinWidth $- borderWithLabel title body- where- title = withDefAttr clientEmphAttr $- hBox [ scopeHeader scope- , case st^.listOverlayRecordCount of- Nothing -> emptyWidget- Just c -> txt " (" <+> str (show c) <+> txt ")"- ]- positionLayer = case layerPos of- OverlayCenter -> centerLayer- OverlayUpperRight -> upperRightLayer- body = vBox [ (padRight (Pad 1) promptMsg) <+>- renderEditor (txt . T.unlines) True (st^.listOverlaySearchInput)- , cursorPositionBorder- , showResults- , fromMaybe emptyWidget footer- ]- plural 1 = ""- plural _ = "s"- cursorPositionBorder =- if st^.listOverlaySearching- then hBorderWithLabel $ txt "[Searching...]"- else case st^.listOverlaySearchResults.L.listSelectedL of- Nothing -> hBorder- Just _ ->- let showingFirst = "Showing first " <> show numSearchResults <>- " result" <> plural numSearchResults- showingAll = "Showing all " <> show numSearchResults <>- " result" <> plural numSearchResults- showing = "Showing " <> show numSearchResults <>- " result" <> plural numSearchResults- msg = case getEditContents (st^.listOverlaySearchInput) of- [""] ->- case st^.listOverlayRecordCount of- Nothing -> showing- Just total -> if numSearchResults < total- then showingFirst- else showingAll- _ -> showing- in hBorderWithLabel $ str $ "[" <> msg <> "]"-- scope = st^.listOverlaySearchScope- promptMsg = scopePrompt scope-- showMessage = center . withDefAttr clientEmphAttr-- showResults- | numSearchResults == 0 = showMessage $ scopeNoResults scope- | otherwise = renderedUserList-- renderedUserList = L.renderList renderItem True (st^.listOverlaySearchResults)- numSearchResults = F.length $ st^.listOverlaySearchResults.L.listElementsL--upperRightLayer :: Widget a -> Widget a-upperRightLayer w =- Widget (hSize w) (vSize w) $ do- result <- render w- c <- getContext- let rWidth = result^.imageL.to imageWidth- leftPaddingAmount = max 0 $ c^.availWidthL - rWidth- paddedImage = translateX leftPaddingAmount $ result^.imageL- off = Location (leftPaddingAmount, 0)- if leftPaddingAmount == 0 then- return result else- return $ addResultOffset off- $ result & imageL .~ paddedImage
+ src/Matterhorn/Draw/ListWindow.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Matterhorn.Draw.ListWindow+ ( drawListWindow+ , WindowPosition(..)+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Brick.Widgets.Edit+import qualified Brick.Widgets.List as L+import Control.Monad.Trans.Reader ( withReaderT )+import qualified Data.Foldable as F+import qualified Data.Text as T+import Graphics.Vty ( imageWidth, translateX)+import Lens.Micro.Platform ( (%~), (.~), to )++import Matterhorn.Themes+import Matterhorn.Types+++hLimitWithPadding :: Int -> Widget n -> Widget n+hLimitWithPadding pad contents = Widget+ { hSize = Fixed+ , vSize = (vSize contents)+ , render =+ withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents+ }++data WindowPosition =+ WindowCenter+ | WindowUpperRight+ deriving (Eq, Show)++-- | Draw a ListWindowState. This draws a bordered box with the+-- window's search input and results list inside the box. The provided+-- functions determine how to render the window in various states.+drawListWindow :: ListWindowState a b+ -- ^ The window state+ -> (b -> Widget Name)+ -- ^ The function to build the window title from the+ -- current search scope+ -> (b -> Widget Name)+ -- ^ The function to generate a message for the search+ -- scope indicating that no results were found+ -> (b -> Widget Name)+ -- ^ The function to generate the editor prompt for the+ -- search scope+ -> (Bool -> a -> Widget Name)+ -- ^ The function to render an item from the window's+ -- list+ -> Maybe (Widget Name)+ -- ^ The footer widget to render underneath the search+ -- results+ -> WindowPosition+ -- ^ How to position the window layer+ -> Int+ -- ^ The maximum window width in columns+ -> Widget Name+drawListWindow st scopeHeader scopeNoResults scopePrompt renderItem footer layerPos maxWinWidth =+ positionLayer $ hLimitWithPadding 10 $ vLimit 25 $+ hLimit maxWinWidth $+ borderWithLabel title body+ where+ title = withDefAttr clientEmphAttr $+ hBox [ scopeHeader scope+ , case st^.listWindowRecordCount of+ Nothing -> emptyWidget+ Just c -> txt " (" <+> str (show c) <+> txt ")"+ ]+ positionLayer = case layerPos of+ WindowCenter -> centerLayer+ WindowUpperRight -> upperRightLayer+ body = vBox [ (padRight (Pad 1) promptMsg) <+>+ renderEditor (txt . T.unlines) True (st^.listWindowSearchInput)+ , cursorPositionBorder+ , showResults+ , fromMaybe emptyWidget footer+ ]+ plural 1 = ""+ plural _ = "s"+ cursorPositionBorder =+ if st^.listWindowSearching+ then hBorderWithLabel $ txt "[Searching...]"+ else case st^.listWindowSearchResults.L.listSelectedL of+ Nothing -> hBorder+ Just _ ->+ let showingFirst = "Showing first " <> show numSearchResults <>+ " result" <> plural numSearchResults+ showingAll = "Showing all " <> show numSearchResults <>+ " result" <> plural numSearchResults+ showing = "Showing " <> show numSearchResults <>+ " result" <> plural numSearchResults+ msg = case getEditContents (st^.listWindowSearchInput) of+ [""] ->+ case st^.listWindowRecordCount of+ Nothing -> showing+ Just total -> if numSearchResults < total+ then showingFirst+ else showingAll+ _ -> showing+ in hBorderWithLabel $ str $ "[" <> msg <> "]"++ scope = st^.listWindowSearchScope+ promptMsg = scopePrompt scope++ showMessage = center . withDefAttr clientEmphAttr++ showResults+ | numSearchResults == 0 = showMessage $ scopeNoResults scope+ | otherwise = renderedUserList++ renderedUserList = L.renderList renderItem True (st^.listWindowSearchResults)+ numSearchResults = F.length $ st^.listWindowSearchResults.L.listElementsL++upperRightLayer :: Widget a -> Widget a+upperRightLayer w =+ Widget (hSize w) (vSize w) $ do+ result <- render w+ c <- getContext+ let rWidth = result^.imageL.to imageWidth+ leftPaddingAmount = max 0 $ c^.availWidthL - rWidth+ paddedImage = translateX leftPaddingAmount $ result^.imageL+ off = Location (leftPaddingAmount, 0)+ if leftPaddingAmount == 0 then+ return result else+ return $ addResultOffset off+ $ result & imageL .~ paddedImage
src/Matterhorn/Draw/Main.hs view
@@ -1,302 +1,166 @@ {-# LANGUAGE MultiWayIf #-}-module Matterhorn.Draw.Main (drawMain) where+{-# LANGUAGE RankNTypes #-}+module Matterhorn.Draw.Main+ ( drawMain+ )+where import Prelude () import Matterhorn.Prelude import Brick import Brick.Widgets.Border-import Brick.Widgets.Border.Style-import Brick.Widgets.Center ( hCenter )-import Brick.Widgets.List ( listElements, listSelectedElement )-import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents )-import Control.Arrow ( (>>>) )-import Data.Char ( isSpace, isPunctuation )-import qualified Data.Foldable as F import Data.List ( intersperse ) import Data.Maybe ( fromJust )-import qualified Data.Map as M-import qualified Data.Sequence as Seq-import qualified Data.Set as S import qualified Data.Text as T-import Data.Text.Zipper ( cursorPosition, insertChar, getText, gotoEOL )-import Data.Time.Calendar ( fromGregorian )-import Data.Time.Clock ( UTCTime(..) )-import qualified Graphics.Vty as Vty-import Lens.Micro.Platform ( (.~), (^?!), to, view, folding )+import Lens.Micro.Platform ( Lens' ) -import Network.Mattermost.Types ( ChannelId, Type(Direct, Private, Group)- , ServerTime(..), UserId, TeamId, teamDisplayName- , teamId+import Network.Mattermost.Types ( Type(Direct, Private, Group)+ , TeamId, teamDisplayName, teamId ) -import Matterhorn.Constants-import Matterhorn.Draw.ChannelList ( renderChannelList, renderChannelListHeader )+import Matterhorn.Draw.ChannelList ( renderChannelList ) import Matterhorn.Draw.Messages+import Matterhorn.Draw.MessageInterface import Matterhorn.Draw.Autocomplete-import Matterhorn.Draw.URLList import Matterhorn.Draw.Util import Matterhorn.Draw.RichText-import Matterhorn.Events.Keybindings-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.Common ( sanitizeUserText )-import Matterhorn.Types.DirectionalSeq ( emptyDirSeq )-import Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL )-import Matterhorn.Types.KeyEvents import qualified Matterhorn.Zipper as Z -previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message-previewFromInput _ _ _ s | s == T.singleton cursorSentinel = Nothing-previewFromInput baseUrl overrideTy uId s =- -- If it starts with a slash but not /me, this has no preview- -- representation- let isCommand = "/" `T.isPrefixOf` s- isEmoteCmd = "/me " `T.isPrefixOf` s- content = if isEmoteCmd- then T.stripStart $ T.drop 3 s- else s- msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy- in if isCommand && not isEmoteCmd- then Nothing- else Just $ Message { _mText = parseMarkdown (Just baseUrl) content- , _mMarkdownSource = content- , _mUser = UserI False uId- , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0- -- The date is not used for preview- -- rendering, but we need to provide one.- -- Ideally we'd just use today's date, but- -- the rendering function is pure so we- -- can't.- , _mType = msgTy- , _mPending = False- , _mDeleted = False- , _mAttachments = mempty- , _mInReplyToMsg = NotAReply- , _mMessageId = Nothing- , _mReactions = mempty- , _mOriginalPost = Nothing- , _mFlagged = False- , _mPinned = False- , _mChannelId = Nothing- }---- | Tokens in spell check highlighting.-data Token =- Ignore Text- -- ^ This bit of text is to be ignored for the purposes of- -- spell-checking.- | Check Text- -- ^ This bit of text should be checked against the spell checker's- -- misspelling list.- deriving (Show)+drawMain :: ChatState -> Mode -> [Widget Name]+drawMain st mode =+ (connectionLayer st : drawAutocompleteLayers st) <>+ [joinBorders $ mainInterface st mode (st^.csCurrentTeamId)] -drawEditorContents :: ChatState -> TeamId -> HighlightSet -> [Text] -> Widget Name-drawEditorContents st tId hs =- let noHighlight = txt . T.unlines- in case st^.csTeam(tId).tsEditState.cedSpellChecker of- Nothing -> noHighlight- Just _ ->- case S.null (st^.csTeam(tId).tsEditState.cedMisspellings) of- True -> noHighlight- False -> doHighlightMisspellings- hs- (st^.csTeam(tId).tsEditState.cedMisspellings)+connectionLayer :: ChatState -> Widget Name+connectionLayer st =+ case st^.csConnectionStatus of+ Connected -> emptyWidget+ Disconnected ->+ Widget Fixed Fixed $ do+ ctx <- getContext+ let aw = ctx^.availWidthL+ w = length msg + 2+ msg = "NOT CONNECTED"+ render $ translateBy (Location (max 0 (aw - w), 0)) $+ withDefAttr errorMessageAttr $+ border $ str msg --- | This function takes a set of misspellings from the spell--- checker, the editor lines, and builds a rendering of the text with--- misspellings highlighted.------ This function processes each line of text from the editor as follows:------ * Tokenize the line based on our rules for what constitutes--- whitespace. We do this because we need to check "words" in the--- user's input against the list of misspellings returned by the spell--- checker. But to do this we need to ignore the same things that--- Aspell ignores, and it ignores whitespace and lots of puncutation.--- We also do this because once we have identified the misspellings--- present in the input, we need to reconstruct the user's input and--- that means preserving whitespace so that the input looks as it was--- originally typed.------ * Once we have a list of tokens -- the whitespace tokens to be--- preserved but ignored and the tokens to be checked -- we check--- each non-whitespace token for presence in the list of misspellings--- reported by the checker.------ * Having indicated which tokens correspond to misspelled words, we--- then need to coallesce adjacent tokens that are of the same--- "misspelling status", i.e., two neighboring tokens (of whitespace--- or check type) need to be coallesced if they both correspond to--- text that is a misspelling or if they both are NOT a misspelling.--- We do this so that the final Brick widget is optimal in that it--- uses a minimal number of box cells to display substrings that have--- the same attribute.------ * Finally we build a widget out of these coallesced tokens and apply--- the misspellingAttr attribute to the misspelled tokens.------ Note that since we have to come to our own conclusion about which--- words are worth checking in the checker's output, sometimes our--- algorithm will differ from aspell in what is considered "part of a--- word" and what isn't. In particular, Aspell is smart about sometimes--- noticing that "'" is an apostrophe and at other times that it is--- a single quote as part of a quoted string. As a result there will--- be cases where Markdown formatting characters interact poorly--- with Aspell's checking to result in misspellings that are *not*--- highlighted.------ One way to deal with this would be to *not* parse the user's input--- as done here, complete with all its Markdown metacharacters, but to--- instead 1) parse the input as Markdown, 2) traverse the Markdown AST--- and extract the words from the relevant subtrees, and 3) spell-check--- those words. The reason we don't do it that way in the first place is--- because 1) the user's input might not be valid markdown and 2) even--- if we did that, we'd still have to do this tokenization operation to--- annotate misspellings and reconstruct the user's raw input.-doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name-doHighlightMisspellings hSet misspellings contents =- -- Traverse the input, gathering non-whitespace into tokens and- -- checking if they appear in the misspelling collection- let whitelist = S.union (hUserSet hSet) (hChannelSet hSet)+mainInterface :: ChatState -> Mode -> Maybe TeamId -> Widget Name+mainInterface st mode mtId =+ vBox [ teamList st+ , body+ ]+ where+ config = st^.csResources.crConfiguration - handleLine t | t == "" = txt " "- handleLine t =- -- For annotated tokens, coallesce tokens of the same type- -- and add attributes for misspellings.- let mkW (Left tok) =- let s = getTokenText tok- in if T.null s- then emptyWidget- else withDefAttr misspellingAttr $ txt $ getTokenText tok- mkW (Right tok) =- let s = getTokenText tok- in if T.null s- then emptyWidget- else txt s+ showChannelList =+ config^.configShowChannelListL ||+ case mtId of+ Nothing -> True+ Just {} -> mode == ChannelSelect - go :: Either Token Token -> [Either Token Token] -> [Either Token Token]- go lst [] = [lst]- go lst (tok:toks) =- case (lst, tok) of- (Left a, Left b) -> go (Left $ combineTokens a b) toks- (Right a, Right b) -> go (Right $ combineTokens a b) toks- _ -> lst : go tok toks+ body = if showChannelList+ then case st^.csChannelListOrientation of+ ChannelListLeft ->+ hBox [channelList, vBorder, mainDisplay]+ ChannelListRight ->+ hBox [mainDisplay, vBorder, channelList]+ else mainDisplay - in hBox $ mkW <$> (go (Right $ Ignore "") $ annotatedTokens t)+ mainDisplay = maybeSubdue messageInterface - combineTokens (Ignore a) (Ignore b) = Ignore $ a <> b- combineTokens (Check a) (Check b) = Check $ a <> b- combineTokens (Ignore a) (Check b) = Check $ a <> b- combineTokens (Check a) (Ignore b) = Check $ a <> b+ channelList = channelListMaybeVlimit mode $+ hLimit channelListWidth $ case mtId of+ Nothing -> fill ' '+ Just tId -> renderChannelList st tId+ channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration+ channelListMaybeVlimit ChannelSelect w =+ Widget (hSize w) (vSize w) $ do+ ctx <- getContext+ render $ vLimit (ctx^.availHeightL - 1) w+ channelListMaybeVlimit _ w = w - getTokenText (Ignore a) = a- getTokenText (Check a) = a+ noMessageInterface = fill ' ' - annotatedTokens t =- -- For every token, check on whether it is a misspelling.- -- The result is Either Token Token where the Left is a- -- misspelling and the Right is not.- checkMisspelling <$> tokenize t (Ignore "")+ messageInterface = fromMaybe noMessageInterface $ do+ tId <- mtId+ let hs = getHighlightSet st tId - checkMisspelling t@(Ignore _) = Right t- checkMisspelling t@(Check s) =- if s `S.member` whitelist- then Right t- else if s `S.member` misspellings- then Left t- else Right t+ channelHeader chan =+ withDefAttr channelHeaderAttr $+ padRight Max $+ renderChannelHeader st tId hs chan - ignoreChar c = isSpace c || isPunctuation c || c == '`' || c == '/' ||- T.singleton c == userSigil || T.singleton c == normalChannelSigil+ focused = st^.csTeam(tId).tsMessageInterfaceFocus == FocusCurrentChannel &&+ threadShowing+ threadShowing = isJust $ st^.csTeam(tId).tsThreadInterface+ channelMessageIface cId =+ drawMessageInterface st hs tId True+ (csChannelMessageInterface(cId))+ True+ focused - tokenize t curTok- | T.null t = [curTok]- | ignoreChar $ T.head t =- case curTok of- Ignore s -> tokenize (T.tail t) (Ignore $ s <> (T.singleton $ T.head t))- Check s -> Check s : tokenize (T.tail t) (Ignore $ T.singleton $ T.head t)- | otherwise =- case curTok of- Ignore s -> Ignore s : tokenize (T.tail t) (Check $ T.singleton $ T.head t)- Check s -> tokenize (T.tail t) (Check $ s <> (T.singleton $ T.head t))+ maybeThreadIface = do+ _ <- st^.csTeam(tId).tsThreadInterface+ return $ drawThreadWindow st tId - in vBox $ handleLine <$> contents+ cId <- st^.csCurrentChannelId(tId)+ ch <- st^?csChannel(cId) -renderUserCommandBox :: ChatState -> TeamId -> HighlightSet -> Widget Name-renderUserCommandBox st tId hs =- let prompt = txt $ case st^.csTeam(tId).tsEditState.cedEditMode of- Replying _ _ -> "reply> "- Editing _ _ -> "edit> "- NewPost -> "> "- inputBox = renderEditor (drawEditorContents st tId hs) True (st^.csTeam(tId).tsEditState.cedEditor)- curContents = getEditContents $ st^.csTeam(tId).tsEditState.cedEditor- multilineContent = length curContents > 1- multilineHints =- hBox [ borderElem bsHorizontal- , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $- st^.csTeam(tId).tsEditState.cedEditor.editContentsL) <>- "/" <> (show $ length curContents) <> "]"- , hBorderWithLabel $ withDefAttr clientEmphAttr $- txt $ "In multi-line mode. Press " <> multiLineToggleKey <>- " to finish."- ]+ let channelUI = channelHeader ch <=> hBorder <=> channelMessageIface cId - replyDisplay = case st^.csTeam(tId).tsEditState.cedEditMode of- Replying msg _ ->- let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply- in hBox [ replyArrow- , addEllipsis $ renderMessage MessageData- { mdMessage = msgWithoutParent- , mdUserName = msgWithoutParent^.mUser.to (printableNameForUserRef st)- , mdParentMessage = Nothing- , mdParentUserName = Nothing- , mdHighlightSet = hs- , mdEditThreshold = Nothing- , mdShowOlderEdits = False- , mdRenderReplyParent = True- , mdIndentBlocks = False- , mdThreadState = NoThread- , mdShowReactions = True- , mdMessageWidthLimit = Nothing- , mdMyUsername = myUsername st- , mdMyUserId = myUserId st- , mdWrapNonhighlightedCodeBlocks = True- , mdTruncateVerbatimBlocks = Nothing- }- ]- _ -> emptyWidget+ return $ fromMaybe channelUI $ do+ tui <- maybeThreadIface+ return $ case config^.configThreadOrientationL of+ ThreadAbove -> tui <=> hBorder <=> channelUI+ ThreadBelow -> channelUI <=> hBorder <=> tui+ ThreadLeft -> tui <+> vBorder <+> channelUI+ ThreadRight -> channelUI <+> vBorder <+> tui - kc = st^.csResources.crConfiguration.configUserKeysL- multiLineToggleKey = ppBinding $ firstActiveBinding kc ToggleMultiLineEvent+ maybeSubdue = if mode == ChannelSelect+ then forceAttr ""+ else id - commandBox = case st^.csTeam(tId).tsEditState.cedEphemeral.eesMultiline of- False ->- let linesStr = "line" <> if numLines == 1 then "" else "s"- numLines = length curContents- in vLimit 1 $ hBox $- prompt : if multilineContent- then [ withDefAttr clientEmphAttr $- str $ "[" <> show numLines <> " " <> linesStr <>- "; Enter: send, " <> T.unpack multiLineToggleKey <>- ": edit, Backspace: cancel] "- , txt $ head curContents- , showCursor (MessageInput tId) (Location (0,0)) $ str " "- ]- else [inputBox]- True -> vLimit multilineHeightLimit inputBox <=> multilineHints- in replyDisplay <=> commandBox+teamList :: ChatState -> Widget Name+teamList st =+ let curTid = st^.csCurrentTeamId+ z = st^.csTeamZipper+ pos = fromJust $ Z.position z+ teams = (\tId -> st^.csTeam(tId)) <$> (concat $ snd <$> Z.toList z)+ numTeams = length teams+ entries = mkEntry <$> teams+ mkEntry ts =+ let tId = teamId $ _tsTeam ts+ unread = uCount > 0+ uCount = unreadCount tId+ tName = ClickableTeamListEntry tId+ in (if Just tId == curTid+ then visible . withDefAttr currentTeamAttr+ else if unread+ then withDefAttr unreadChannelAttr+ else id) $+ clickable tName $ txt $+ (T.strip $ sanitizeUserText $ teamDisplayName $ _tsTeam ts)+ unreadCount tId = sum $ fmap (nonDMChannelListGroupUnread . fst) $+ Z.toList $ st^.csTeam(tId).tsFocus+ in if numTeams == 1+ then emptyWidget+ else vBox [ hBox [ padRight (Pad 1) $ txt $ T.pack $ "Teams (" <> show (pos + 1) <> "/" <> show numTeams <> "):"+ , vLimit 1 $ viewport TeamList Horizontal $+ hBox $+ intersperse (txt " ") entries+ ]+ , hBorder+ ] -renderChannelHeader :: ChatState -> TeamId -> HighlightSet -> Maybe ClientChannel -> Widget Name-renderChannelHeader _ _ _ Nothing =- txt " "-renderChannelHeader st tId hs (Just chan) =+renderChannelHeader :: ChatState -> TeamId -> HighlightSet -> ClientChannel -> Widget Name+renderChannelHeader st tId hs chan = let chnType = chan^.ccInfo.cdType topicStr = chan^.ccInfo.cdHeader userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts@@ -341,553 +205,28 @@ baseUrl = serverBaseUrl st tId in renderText' (Just baseUrl) (myUsername st)- hs (Just (mkClickableInline Nothing (Just $ ChannelTopic $ chan^.ccInfo.cdChannelId)))+ hs (Just (mkClickableInline Nothing (ChannelTopic $ chan^.ccInfo.cdChannelId))) (channelNameString <> maybeTopic) -renderCurrentChannelDisplay :: ChatState -> TeamId -> HighlightSet -> Widget Name-renderCurrentChannelDisplay st tId hs = header <=> hBorder <=> messages- where- header =- if st^.csResources.crConfiguration.configShowChannelListL- then channelHeader- else headerWithStatus-- headerWithStatus =- -- Render the channel list header next to the channel header- -- itself. We want them to be separated by a vertical border,- -- but we want the border to be as high as the tallest of the- -- two. To make that work we need to render the two and then- -- render a border between them that is the same height as the- -- taller of the two. We can't do that without making a custom- -- widget which is why we take this approach here rather than- -- just putting them all in an hBox.- Widget Fixed Fixed $ do- ctx <- getContext- statusBox <- render $- hLimit (configChannelListWidth $ st^.csResources.crConfiguration) $- (renderChannelListHeader st tId)-- let channelHeaderWidth = ctx^.availWidthL -- (Vty.imageWidth $ statusBox^.imageL) - 1-- channelHeaderResult <- render $ hLimit channelHeaderWidth channelHeader-- let maxHeight = max (Vty.imageHeight $ statusBox^.imageL)- (Vty.imageHeight $ channelHeaderResult^.imageL)- statusBoxWidget = resultToWidget statusBox- headerWidget = resultToWidget channelHeaderResult- borderWidget = vLimit maxHeight vBorder-- render $ if st^.csTeam(tId).tsMode == ChannelSelect- then headerWidget- else hBox $ case st^.csChannelListOrientation of- ChannelListLeft ->- [ statusBoxWidget- , borderWidget- , headerWidget- ]- ChannelListRight ->- [ headerWidget- , borderWidget- , statusBoxWidget- ]-- mcId = st^.(csCurrentChannelId tId)- mChan = maybe Nothing (\cId -> st^?csChannel(cId)) mcId-- channelHeader =- withDefAttr channelHeaderAttr $- padRight Max $- renderChannelHeader st tId hs mChan-- messages = padTop Max chatText-- chatText =- case mcId of- Nothing -> fill ' '- Just cId ->- case st^.csTeam(tId).tsMode of- MessageSelect ->- freezeBorders $- renderMessagesWithSelect cId (st^.csTeam(tId).tsMessageSelect) (channelMessages cId)- MessageSelectDeleteConfirm ->- freezeBorders $- renderMessagesWithSelect cId (st^.csTeam(tId).tsMessageSelect) (channelMessages cId)- _ ->- cached (ChannelMessages cId) $- freezeBorders $- renderLastMessages st hs (getEditedMessageCutoff cId st) $- retrogradeMsgsWithThreadStates $- reverseMessages $- channelMessages cId-- renderMessagesWithSelect cId (MessageSelectState selMsgId) msgs =- -- In this case, we want to fill the message list with messages- -- but use the post ID as a cursor. To do this efficiently we- -- only want to render enough messages to fill the screen.- --- -- If the message area is H rows high, this actually renders at- -- most 2H rows' worth of messages and then does the appropriate- -- cropping. This way we can simplify the math needed to figure- -- out how to crop while bounding the number of messages we- -- render around the cursor.- --- -- First, we sanity-check the application state because under- -- some conditions, the selected message might be gone (e.g.- -- deleted).- let (s, (before, after)) = splitDirSeqOn (\(m, _) -> m^.mMessageId == selMsgId) msgsWithStates- msgsWithStates = chronologicalMsgsWithThreadStates msgs- in case s of- Nothing ->- renderLastMessages st hs (getEditedMessageCutoff cId st) before- Just m ->- unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st hs Nothing)-- channelMessages cId =- -- If the channel is empty, add an informative message to the- -- message listing to make it explicit that this channel does- -- not yet have any messages.- let cutoff = getNewMessageCutoff cId st- messageListing = getMessageListing cId st- in if F.null messageListing- then addMessage (emptyChannelFillerMessage st cId) emptyDirSeq- else insertTransitions messageListing- cutoff- (getDateFormat st)- (st ^. timeZone)---- | Construct a single message to be displayed in the specified channel--- when it does not yet have any user messages posted to it.-emptyChannelFillerMessage :: ChatState -> ChannelId -> Message-emptyChannelFillerMessage st cId =- newMessageOfType msg (C Informative) ts- where- -- This is a bogus timestamp, but its value does not matter- -- because it is only used to create a message that will be- -- shown in a channel with no date transitions (which would- -- otherwise include this bogus date) or other messages (which- -- would make for a broken message sorting).- ts = ServerTime $ UTCTime (toEnum 0) 0- chan = fromJust $ findChannelById cId (st^.csChannels)- chanName = mkChannelName st (chan^.ccInfo)- msg = case chan^.ccInfo.cdType of- Direct ->- let u = chan^.ccInfo.cdDMUserId >>= flip userById st- in case u of- Nothing -> userMsg Nothing- Just _ -> userMsg (Just chanName)- Group ->- groupMsg (chan^.ccInfo.cdDisplayName)- _ ->- chanMsg chanName- userMsg (Just cn) = "You have not yet sent any direct messages to " <> cn <> "."- userMsg Nothing = "You have not yet sent any direct messages to this user."- groupMsg us = "There are not yet any direct messages in the group " <> us <> "."- chanMsg cn = "There are not yet any messages in the " <> cn <> " channel."--getMessageListing :: ChannelId -> ChatState -> Messages-getMessageListing cId st =- st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown)- where isShown m- | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True- | otherwise = not $ isJoinLeave m--insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages-insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT- where anyNondeletedNewMessages t =- isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms)- newMessagesT = case cutoff of- Nothing -> []- Just Hide -> []- Just (NewPostsAfterServerTime t)- | anyNondeletedNewMessages t -> [newMessagesMsg $ justAfter t]- | otherwise -> []- Just (NewPostsStartingAt t)- | anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t]- | otherwise -> []- newMessagesMsg d = newMessageOfType (T.pack "New Messages")- (C NewMessagesTransition) d--renderChannelSelectPrompt :: ChatState -> TeamId -> Widget Name-renderChannelSelectPrompt st tId =- let e = st^.csTeam(tId).tsChannelSelectState.channelSelectInput- in withDefAttr channelSelectPromptAttr $- (txt "Switch to channel [use ^ and $ to anchor]: ") <+>- (renderEditor (txt . T.concat) True e)--drawMain :: Bool -> ChatState -> [Widget Name]-drawMain useColor st =- let maybeColor = if useColor then id else forceAttr "invalid"- mtId = st^.csCurrentTeamId- in maybeColor <$>- [ connectionLayer st- , maybe emptyWidget (autocompleteLayer st) mtId- , joinBorders $ mainInterface st mtId- ]--teamList :: ChatState -> Widget Name-teamList st =- let curTid = st^.csCurrentTeamId- z = st^.csTeamZipper- pos = fromJust $ Z.position z- teams = (\tId -> st^.csTeam(tId)) <$> (concat $ snd <$> Z.toList z)- numTeams = length teams- entries = mkEntry <$> teams- mkEntry ts =- let tId = teamId $ _tsTeam ts- unread = uCount > 0- uCount = unreadCount tId- tName = ClickableTeamListEntry tId- in (if Just tId == curTid- then visible . withDefAttr currentTeamAttr- else if unread- then withDefAttr unreadChannelAttr- else id) $- clickable tName $ txt $- (T.strip $ sanitizeUserText $ teamDisplayName $ _tsTeam ts)- unreadCount tId = sum $ fmap (nonDMChannelListGroupUnread . fst) $- Z.toList $ st^.csTeam(tId).tsFocus- in if numTeams == 1- then emptyWidget- else vBox [ hBox [ padRight (Pad 1) $ txt $ T.pack $ "Teams (" <> show (pos + 1) <> "/" <> show numTeams <> "):"- , vLimit 1 $ viewport TeamList Horizontal $- hBox $- intersperse (txt " ") entries- ]- , hBorder- ]--connectionLayer :: ChatState -> Widget Name-connectionLayer st =- case st^.csConnectionStatus of- Connected -> emptyWidget- Disconnected ->- Widget Fixed Fixed $ do- ctx <- getContext- let aw = ctx^.availWidthL- w = length msg + 2- msg = "NOT CONNECTED"- render $ translateBy (Location (max 0 (aw - w), 0)) $- withDefAttr errorMessageAttr $- border $ str msg--urlSelectBottomBar :: ChatState -> TeamId -> Widget Name-urlSelectBottomBar st tId =- case listSelectedElement $ st^.csTeam(tId).tsUrlList of- Nothing -> hBorder- Just (_, (_, link)) ->- let options = [ ( isFile- , ev SaveAttachmentEvent- , "save attachment"- )- ]- ev = keyEventBindings st (urlSelectKeybindings tId)- isFile entry = case entry^.linkTarget of- LinkFileId {} -> True- _ -> False- optionList = if null usableOptions- then txt "(no actions available for this link)"- else hBox $ intersperse (txt " ") usableOptions- usableOptions = catMaybes $ mkOption <$> options- mkOption (f, k, desc) = if f link- then Just $ withDefAttr urlSelectStatusAttr (txt k) <+>- txt (":" <> desc)- else Nothing- in hBox [ borderElem bsHorizontal- , txt "["- , txt "Options: "- , optionList- , txt "]"- , hBorder- ]--messageSelectBottomBar :: ChatState -> TeamId -> Widget Name-messageSelectBottomBar st tId =- case getSelectedMessage tId st of- Nothing -> emptyWidget- Just postMsg ->- let optionList = if null usableOptions- then txt "(no actions available for this message)"- else hBox $ intersperse (txt " ") usableOptions- usableOptions = catMaybes $ mkOption <$> options- mkOption (f, k, desc) = if f postMsg- then Just $ withDefAttr messageSelectStatusAttr (txt k) <+>- txt (":" <> desc)- else Nothing- numURLs = Seq.length $ msgURLs postMsg- s = if numURLs == 1 then "" else "s"- hasURLs = numURLs > 0- openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s- hasVerb = isJust (findVerbatimChunk (postMsg^.mText))- ev = keyEventBindings st (messageSelectKeybindings tId)- -- make sure these keybinding pieces are up-to-date!- options = [ ( not . isGap- , ev YankWholeMessageEvent- , "yank-all"- )- , ( \m -> isFlaggable m && not (m^.mFlagged)- , ev FlagMessageEvent- , "flag"- )- , ( \m -> isFlaggable m && m^.mFlagged- , ev FlagMessageEvent- , "unflag"- )- , ( isPostMessage- , ev CopyPostLinkEvent- , "copy-link"- )- , ( \m -> isPinnable m && not (m^.mPinned)- , ev PinMessageEvent- , "pin"- )- , ( \m -> isPinnable m && m^.mPinned- , ev PinMessageEvent- , "unpin"- )- , ( isReplyable- , ev ReplyMessageEvent- , "reply"- )- , ( not . isGap- , ev ViewMessageEvent- , "view"- )- , ( isGap- , ev FillGapEvent- , "load messages"- )- , ( \m -> isMine st m && isEditable m- , ev EditMessageEvent- , "edit"- )- , ( \m -> isMine st m && isDeletable m- , ev DeleteMessageEvent- , "delete"- )- , ( const hasURLs- , ev OpenMessageURLEvent- , openUrlsMsg- )- , ( const hasVerb- , ev YankMessageEvent- , "yank-code"- )- , ( isReactable- , ev ReactToMessageEvent- , "react"- )- ]-- in hBox [ borderElem bsHorizontal- , txt "["- , optionList- , txt "]"- , hBorder- ]---- | Resolve the specified key event into a pretty-printed--- representation of the active bindings for that event, using the--- specified key handler map builder. If the event has more than one--- active binding, the bindings are comma-delimited in the resulting--- string.-keyEventBindings :: ChatState- -- ^ The current application state- -> (KeyConfig -> KeyHandlerMap)- -- ^ The function to obtain the relevant key handler- -- map- -> KeyEvent- -- ^ The key event to look up- -> T.Text-keyEventBindings st mkBindingsMap e =- let keyconf = st^.csResources.crConfiguration.configUserKeysL- KeyHandlerMap keymap = mkBindingsMap keyconf- in T.intercalate ","- [ ppBinding (eventToBinding k)- | KH { khKey = k- , khHandler = h- } <- M.elems keymap- , kehEventTrigger h == ByEvent e- ]--maybePreviewViewport :: TeamId -> Widget Name -> Widget Name-maybePreviewViewport tId w =- Widget Greedy Fixed $ do- result <- render w- case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of- False -> return result- True ->- render $ vLimit previewMaxHeight $ viewport (MessagePreviewViewport tId) Vertical $- (resultToWidget result)--inputPreview :: ChatState -> TeamId -> HighlightSet -> Widget Name-inputPreview st tId hs | not $ st^.csResources.crConfiguration.configShowMessagePreviewL = emptyWidget- | otherwise = thePreview- where- uId = myUserId st- -- Insert a cursor sentinel into the input text just before- -- rendering the preview. We use the inserted sentinel (which is- -- not rendered) to get brick to ensure that the line the cursor is- -- on is visible in the preview viewport. We put the sentinel at- -- the *end* of the line because it will still influence markdown- -- parsing and can create undesirable/confusing churn in the- -- rendering while the cursor moves around. If the cursor is at the- -- end of whatever line the user is editing, that is very unlikely- -- to be a problem.- curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $- st^.csTeam(tId).tsEditState.cedEditor.editContentsL- curStr = T.intercalate "\n" curContents- overrideTy = case st^.csTeam(tId).tsEditState.cedEditMode of- Editing _ ty -> Just ty- _ -> Nothing- baseUrl = serverBaseUrl st tId- previewMsg = previewFromInput baseUrl overrideTy uId curStr- thePreview = let noPreview = str "(No preview)"- msgPreview = case previewMsg of- Nothing -> noPreview- Just pm -> if T.null curStr- then noPreview- else prview pm $ getParentMessage st pm- prview m p = renderMessage MessageData- { mdMessage = m- , mdUserName = m^.mUser.to (printableNameForUserRef st)- , mdParentMessage = p- , mdParentUserName = p >>= (^.mUser.to (printableNameForUserRef st))- , mdHighlightSet = hs- , mdEditThreshold = Nothing- , mdShowOlderEdits = False- , mdRenderReplyParent = True- , mdIndentBlocks = True- , mdThreadState = NoThread- , mdShowReactions = True- , mdMessageWidthLimit = Nothing- , mdMyUsername = myUsername st- , mdMyUserId = myUserId st- , mdWrapNonhighlightedCodeBlocks = True- , mdTruncateVerbatimBlocks = Nothing- }- in (maybePreviewViewport tId msgPreview) <=>- hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")--userInputArea :: ChatState -> TeamId -> HighlightSet -> Widget Name-userInputArea st tId hs =- let urlSelectInputArea = hCenter $ hBox [ txt "Press "- , withDefAttr clientEmphAttr $ txt "Enter"- , txt " to open the selected URL or "- , withDefAttr clientEmphAttr $ txt "Escape"- , txt " to cancel."- ]- in case st^.csTeam(tId).tsMode of- ChannelSelect -> renderChannelSelectPrompt st tId- UrlSelect -> urlSelectInputArea- SaveAttachmentWindow {} -> urlSelectInputArea- MessageSelectDeleteConfirm -> renderDeleteConfirm- _ -> renderUserCommandBox st tId hs--renderDeleteConfirm :: Widget Name-renderDeleteConfirm =- hCenter $ txt "Are you sure you want to delete the selected message? (y/n)"--mainInterface :: ChatState -> Maybe TeamId -> Widget Name-mainInterface st mtId =- vBox [ teamList st- , body- ]+drawThreadWindow :: ChatState -> TeamId -> Widget Name+drawThreadWindow st tId = withDefAttr threadAttr body where- showChannelList =- st^.csResources.crConfiguration.configShowChannelListL ||- case mtId of- Nothing -> True- Just tId -> st^.csTeam(tId).tsMode == ChannelSelect- body = if showChannelList- then case st^.csChannelListOrientation of- ChannelListLeft ->- hBox [channelList, vBorder, mainDisplay]- ChannelListRight ->- hBox [mainDisplay, vBorder, channelList]- else mainDisplay- channelList = hLimit channelListWidth $ case mtId of- Nothing -> fill ' '- Just tId -> renderChannelList st tId- channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration-- mainDisplay =- case mtId of- Nothing ->- vBox [ fill ' '- , hBorder- , vLimit 1 $ fill ' '- ]- Just tId ->- let hs = getHighlightSet st tId- in vBox [ channelContents tId hs- , bottomBorder tId hs- , inputPreview st tId hs- , userInputArea st tId hs- ]-- channelContents tId hs =- case st^.csTeam(tId).tsMode of- UrlSelect -> renderUrlList st tId- SaveAttachmentWindow {} -> renderUrlList st tId- _ -> maybeSubdue tId $ renderCurrentChannelDisplay st tId hs-- bottomBorder tId hs =- case st^.csTeam(tId).tsMode of- MessageSelect -> messageSelectBottomBar st tId- UrlSelect -> urlSelectBottomBar st tId- SaveAttachmentWindow {} -> urlSelectBottomBar st tId- _ -> maybeSubdue tId $ hBox- [ showAttachmentCount tId- , hBorder- , showTypingUsers tId hs- , showBusy- ]-- kc = st^.csResources.crConfiguration.configUserKeysL- showAttachmentCount tId =- let count = length $ listElements $ st^.csTeam(tId).tsEditState.cedAttachmentList- in if count == 0- then emptyWidget- else hBox [ borderElem bsHorizontal- , withDefAttr clientMessageAttr $- txt $ "(" <> (T.pack $ show count) <> " attachment" <>- (if count == 1 then "" else "s") <> "; "- , withDefAttr clientEmphAttr $- txt $ ppBinding (firstActiveBinding kc ShowAttachmentListEvent)- , txt " to manage)"- ]-- showTypingUsers tId hs =- case st^.csCurrentChannelId(tId) of- Nothing -> emptyWidget- Just cId ->- case st^?csChannel(cId) of- Nothing -> emptyWidget- Just chan ->- let format = renderText' Nothing (myUsername st) hs Nothing- in case allTypingUsers (chan^.ccInfo.cdTypingUsers) of- [] -> emptyWidget- [uId] | Just un <- usernameForUserId uId st ->- format $ "[" <> addUserSigil un <> " is typing]"- [uId1, uId2] | Just un1 <- usernameForUserId uId1 st- , Just un2 <- usernameForUserId uId2 st ->- format $ "[" <> addUserSigil un1 <> " and " <> addUserSigil un2 <> " are typing]"- _ -> format "[several people are typing]"+ ti :: Lens' ChatState ThreadInterface+ ti = unsafeThreadInterface(tId) - showBusy = case st^.csWorkerIsBusy of- Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)- Just Nothing -> hLimit 2 hBorder <+> txt "*"- Nothing -> emptyWidget+ hs = getHighlightSet st tId+ cId = st^.ti.miChannelId - maybeSubdue tId =- if st^.csTeam(tId).tsMode == ChannelSelect- then forceAttr ""- else id+ titleText = case st^?csChannel(cId) of+ Nothing -> "Thread"+ Just chan ->+ let prefix = case chan^.ccInfo.cdType of+ Group -> "Thread with "+ Direct -> "Thread with "+ _ -> "Thread in "+ in prefix <> mkChannelName st (chan^.ccInfo) -replyArrow :: Widget a-replyArrow =- Widget Fixed Fixed $ do- ctx <- getContext- let bs = ctx^.ctxBorderStyleL- render $ str [' ', bsCornerTL bs, '▸']+ title = renderText' Nothing "" hs Nothing titleText+ focused = st^.csTeam(tId).tsMessageInterfaceFocus == FocusThread+ body = title <=> hBorder <=> messageUI+ messageUI = drawMessageInterface st hs tId False ti False focused
src/Matterhorn/Draw/ManageAttachments.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.Draw.ManageAttachments- ( drawManageAttachments+ ( drawAttachmentList+ , drawFileBrowser ) where @@ -12,8 +14,7 @@ import qualified Brick.Widgets.FileBrowser as FB import Brick.Widgets.List import Data.Maybe ( fromJust )--import Network.Mattermost.Types ( TeamId )+import Lens.Micro.Platform ( Lens' ) import Matterhorn.Types import Matterhorn.Types.KeyEvents@@ -21,28 +22,15 @@ import Matterhorn.Themes -drawManageAttachments :: ChatState -> TeamId -> Widget Name-drawManageAttachments st tId =- topLayer- where- topLayer = case st^.csTeam(tId).tsMode of- ManageAttachments -> drawAttachmentList st tId- ManageAttachmentsBrowseFiles -> drawFileBrowser st tId- _ -> error "BUG: drawManageAttachments called in invalid mode"--drawAttachmentList :: ChatState -> TeamId -> Widget Name-drawAttachmentList st tId =+drawAttachmentList :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name+drawAttachmentList st which = let addBinding = ppBinding $ firstActiveBinding kc AttachmentListAddEvent delBinding = ppBinding $ firstActiveBinding kc AttachmentListDeleteEvent escBinding = ppBinding $ firstActiveBinding kc CancelEvent openBinding = ppBinding $ firstActiveBinding kc AttachmentOpenEvent kc = st^.csResources.crConfiguration.configUserKeysL- in centerLayer $- hLimit 60 $- vLimit 15 $- joinBorders $- borderWithLabel (withDefAttr clientEmphAttr $ txt "Attachments") $- vBox [ renderList renderAttachmentItem True (st^.csTeam(tId).tsEditState.cedAttachmentList)+ in borderWithLabel (withDefAttr clientEmphAttr $ txt "Attachments") $+ vBox [ renderList renderAttachmentItem True (st^.which.miEditor.esAttachmentList) , hBorder , hCenter $ withDefAttr clientMessageAttr $ txt $ addBinding <> ":add " <>@@ -55,13 +43,10 @@ renderAttachmentItem _ d = padRight Max $ str $ FB.fileInfoSanitizedFilename $ attachmentDataFileInfo d -drawFileBrowser :: ChatState -> TeamId -> Widget Name-drawFileBrowser st tId =- centerLayer $- hLimit 60 $- vLimit 20 $+drawFileBrowser :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name+drawFileBrowser st which = borderWithLabel (withDefAttr clientEmphAttr $ txt "Attach File") $ -- invariant: cedFileBrowser is not Nothing if appMode is -- ManageAttachmentsBrowseFiles, and that is the only way to reach -- this code, ergo the fromJust.- FB.renderFileBrowser True $ fromJust (st^.csTeam(tId).tsEditState.cedFileBrowser)+ FB.renderFileBrowser True $ fromJust (st^.which.miEditor.esFileBrowser)
+ src/Matterhorn/Draw/MessageDeleteConfirm.hs view
@@ -0,0 +1,28 @@+module Matterhorn.Draw.MessageDeleteConfirm+ ( drawMessageDeleteConfirm+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import qualified Data.Text as T++import Matterhorn.Types+import Matterhorn.Themes+++drawMessageDeleteConfirm :: Widget Name+drawMessageDeleteConfirm =+ let msg = "Are you sure you want to delete the selected message? (y/n)"+ in centerLayer $+ borderWithLabel (withAttr channelListHeaderAttr $ txt "Confirm") $+ hLimit (T.length msg + 4) $+ vLimit 3 $+ center $+ withDefAttr errorMessageAttr $+ txt msg+
+ src/Matterhorn/Draw/MessageInterface.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE RankNTypes #-}+module Matterhorn.Draw.MessageInterface+ ( drawMessageInterface+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+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.Keybindings+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.KeyEvents+import Matterhorn.Types.RichText+++drawMessageInterface :: ChatState+ -> HighlightSet+ -> TeamId+ -> Bool+ -> Lens' ChatState (MessageInterface Name i)+ -> Bool+ -> Bool+ -> Widget Name+drawMessageInterface st hs tId showNewMsgLine which renderReplyIndent focused =+ interfaceContents+ where+ inMsgSelect = st^.which.miMode == MessageSelect+ eName = getName $ st^.which.miEditor.esEditor+ region = MessageInterfaceMessages eName+ previewVpName = MessagePreviewViewport eName++ interfaceContents =+ case st^.which.miMode of+ Compose -> renderMessages False+ MessageSelect -> renderMessages True+ ShowUrlList -> drawUrlSelectWindow st hs which+ SaveAttachment {} -> drawSaveAttachmentWindow st which+ ManageAttachments -> drawAttachmentList st which+ BrowseFiles -> drawFileBrowser st which++ renderMessages inMsgSel =+ vBox [ freezeBorders $+ renderMessageListing st inMsgSel showNewMsgLine tId hs which renderReplyIndent region+ , bottomBorder+ , inputPreview st (which.miEditor) tId previewVpName hs+ , inputArea st (which.miEditor) focused hs+ ]++ bottomBorder =+ if inMsgSelect+ then messageSelectBottomBar st tId which+ else hBox [ showAttachmentCount+ , hBorder+ , showTypingUsers+ , showBusy+ ]++ showBusy = case st^.csWorkerIsBusy of+ Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)+ Just Nothing -> hLimit 2 hBorder <+> txt "*"+ Nothing -> emptyWidget++ showTypingUsers =+ let format = renderText' Nothing (myUsername st) hs Nothing+ in case allTypingUsers (st^.which.miEditor.esEphemeral.eesTypingUsers) of+ [] -> emptyWidget+ [uId] | Just un <- usernameForUserId uId st ->+ format $ "[" <> addUserSigil un <> " is typing]"+ [uId1, uId2] | Just un1 <- usernameForUserId uId1 st+ , Just un2 <- usernameForUserId uId2 st ->+ format $ "[" <> addUserSigil un1 <> " and " <> addUserSigil un2 <> " are typing]"+ _ -> format "[several people are typing]"++ kc = st^.csResources.crConfiguration.configUserKeysL+ showAttachmentCount =+ let count = length $ listElements $ st^.which.miEditor.esAttachmentList+ in if count == 0+ then emptyWidget+ else hBox [ hLimit 1 hBorder+ , withDefAttr clientMessageAttr $+ txt $ "(" <> (T.pack $ show count) <> " attachment" <>+ (if count == 1 then "" else "s") <> "; "+ , withDefAttr clientEmphAttr $+ txt $ ppBinding (firstActiveBinding kc ShowAttachmentListEvent)+ , txt " to manage)"+ ]++messageSelectBottomBar :: ChatState+ -> TeamId+ -> Lens' ChatState (MessageInterface Name i)+ -> Widget Name+messageSelectBottomBar st tId which =+ case getSelectedMessage which st of+ Nothing -> emptyWidget+ Just postMsg ->+ let optionList = if null usableOptions+ then txt "(no actions available for this message)"+ else hBox $ intersperse (txt " ") usableOptions+ usableOptions = catMaybes $ mkOption <$> options+ mkOption (f, k, desc) = if f postMsg+ then Just $ withDefAttr messageSelectStatusAttr (txt k) <+>+ txt (":" <> desc)+ else Nothing+ numURLs = Seq.length $ msgURLs postMsg+ s = if numURLs == 1 then "" else "s"+ hasURLs = numURLs > 0+ openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s+ hasVerb = isJust (findVerbatimChunk (postMsg^.mText))+ ev = keyEventBindings st (messageSelectKeybindings tId which)+ -- make sure these keybinding pieces are up-to-date!+ options = [ ( not . isGap+ , ev YankWholeMessageEvent+ , "yank-all"+ )+ , ( \m -> isFlaggable m && not (m^.mFlagged)+ , ev FlagMessageEvent+ , "flag"+ )+ , ( \m -> isFlaggable m && m^.mFlagged+ , ev FlagMessageEvent+ , "unflag"+ )+ , ( isReplyable+ , ev OpenThreadEvent+ , "thread"+ )+ , ( isPostMessage+ , ev CopyPostLinkEvent+ , "copy-link"+ )+ , ( \m -> isPinnable m && not (m^.mPinned)+ , ev PinMessageEvent+ , "pin"+ )+ , ( \m -> isPinnable m && m^.mPinned+ , ev PinMessageEvent+ , "unpin"+ )+ , ( isReplyable+ , ev ReplyMessageEvent+ , "reply"+ )+ , ( not . isGap+ , ev ViewMessageEvent+ , "view"+ )+ , ( isGap+ , ev FillGapEvent+ , "load messages"+ )+ , ( \m -> isMine st m && isEditable m+ , ev EditMessageEvent+ , "edit"+ )+ , ( \m -> isMine st m && isDeletable m+ , ev DeleteMessageEvent+ , "delete"+ )+ , ( const hasURLs+ , ev OpenMessageURLEvent+ , openUrlsMsg+ )+ , ( const hasVerb+ , ev YankMessageEvent+ , "yank-code"+ )+ , ( isReactable+ , ev ReactToMessageEvent+ , "react"+ )+ ]++ in hBox [ hLimit 1 hBorder+ , txt "["+ , optionList+ , txt "]"+ , hBorder+ ]++renderMessageListing :: ChatState+ -> Bool+ -> Bool+ -> TeamId+ -> HighlightSet+ -> Lens' ChatState (MessageInterface Name i)+ -> Bool+ -> Name+ -> Widget Name+renderMessageListing st inMsgSelect showNewMsgLine tId hs which renderReplyIndent region =+ messages+ where+ mcId = st^.(csCurrentChannelId tId)++ messages = padTop Max chatText++ chatText =+ case mcId of+ Nothing -> fill ' '+ Just cId ->+ if inMsgSelect+ then freezeBorders $+ renderMessagesWithSelect cId (st^.which.miMessageSelect) (buildMessages cId)+ else cached region $+ freezeBorders $+ renderLastMessages st hs (getEditedMessageCutoff cId st) renderReplyIndent region $+ retrogradeMsgsWithThreadStates $+ reverseMessages $+ buildMessages cId++ renderMessagesWithSelect cId (MessageSelectState selMsgId) msgs =+ -- In this case, we want to fill the message list with messages+ -- but use the post ID as a cursor. To do this efficiently we+ -- only want to render enough messages to fill the screen.+ --+ -- If the message area is H rows high, this actually renders at+ -- most 2H rows' worth of messages and then does the appropriate+ -- cropping. This way we can simplify the math needed to figure+ -- out how to crop while bounding the number of messages we+ -- render around the cursor.+ --+ -- First, we sanity-check the application state because under+ -- some conditions, the selected message might be gone (e.g.+ -- deleted).+ let (s, (before, after)) = splitDirSeqOn (\(m, _) -> m^.mMessageId == selMsgId) msgsWithStates+ msgsWithStates = chronologicalMsgsWithThreadStates msgs+ in case s of+ Nothing ->+ renderLastMessages st hs (getEditedMessageCutoff cId st) renderReplyIndent region before+ Just m ->+ unsafeRenderMessageSelection (m, (before, after))+ (renderSingleMessage st hs renderReplyIndent Nothing) region++ buildMessages cId =+ -- If the message list is empty, add an informative message to+ -- the message listing to make it explicit that this listing is+ -- empty.+ let cutoff = if showNewMsgLine+ then getNewMessageCutoff cId st+ else Nothing+ ms = filterMessageListing st (which.miMessages)+ in if F.null ms+ then addMessage (emptyChannelFillerMessage st cId) emptyDirSeq+ else insertTransitions ms+ cutoff+ (getDateFormat st)+ (st ^. timeZone)++insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages+insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT+ where anyNondeletedNewMessages t =+ isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms)+ newMessagesT = case cutoff of+ Nothing -> []+ Just Hide -> []+ Just (NewPostsAfterServerTime t)+ | anyNondeletedNewMessages t -> [newMessagesMsg $ justAfter t]+ | otherwise -> []+ Just (NewPostsStartingAt t)+ | anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t]+ | otherwise -> []+ newMessagesMsg d = newMessageOfType (T.pack "New Messages")+ (C NewMessagesTransition) d++-- | Construct a single message to be displayed in the specified channel+-- when it does not yet have any user messages posted to it.+emptyChannelFillerMessage :: ChatState -> ChannelId -> Message+emptyChannelFillerMessage st cId =+ newMessageOfType msg (C Informative) ts+ where+ -- This is a bogus timestamp, but its value does not matter+ -- because it is only used to create a message that will be+ -- shown in a channel with no date transitions (which would+ -- otherwise include this bogus date) or other messages (which+ -- would make for a broken message sorting).+ ts = ServerTime $ UTCTime (toEnum 0) 0+ chan = fromJust $ findChannelById cId (st^.csChannels)+ chanName = mkChannelName st (chan^.ccInfo)+ msg = case chan^.ccInfo.cdType of+ Direct ->+ let u = chan^.ccInfo.cdDMUserId >>= flip userById st+ in case u of+ Nothing -> userMsg Nothing+ Just _ -> userMsg (Just chanName)+ Group ->+ groupMsg (chan^.ccInfo.cdDisplayName)+ _ ->+ chanMsg chanName+ userMsg (Just cn) = "You have not yet sent any direct messages to " <> cn <> "."+ userMsg Nothing = "You have not yet sent any direct messages to this user."+ groupMsg us = "There are not yet any direct messages in the group " <> us <> "."+ chanMsg cn = "There are not yet any messages in the " <> cn <> " channel."++filterMessageListing :: ChatState -> Traversal' ChatState Messages -> Messages+filterMessageListing st msgsWhich =+ st ^?! msgsWhich . to (filterMessages isShown)+ where isShown m+ | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True+ | otherwise = not $ isJoinLeave m++inputArea :: ChatState+ -> Lens' ChatState (EditState Name)+ -> Bool+ -> HighlightSet+ -> Widget Name+inputArea st which focused hs =+ let replyPrompt = "reply> "+ normalPrompt = "> "+ editPrompt = "edit> "+ showReplyPrompt = st^.which.esShowReplyPrompt+ maybeHighlight = if focused+ then withDefAttr focusedEditorPromptAttr+ else id+ prompt = maybeHighlight $+ reportExtent (MessageInputPrompt $ getName editor) $+ txt $ case st^.which.esEditMode of+ Replying {} ->+ if showReplyPrompt then replyPrompt else normalPrompt+ Editing {} ->+ editPrompt+ NewPost ->+ normalPrompt+ editor = st^.which.esEditor+ inputBox = renderEditor (drawEditorContents st which hs) True editor+ curContents = getEditContents editor+ multilineContent = length curContents > 1+ multilineHints =+ hBox [ hLimit 1 hBorder+ , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $+ editor^.editContentsL) <>+ "/" <> (show $ length curContents) <> "]"+ , hBorderWithLabel $ withDefAttr clientEmphAttr $+ txt $ "In multi-line mode. Press " <> multiLineToggleKey <>+ " to finish."+ ]++ replyDisplay = case st^.which.esEditMode of+ Replying msg _ | showReplyPrompt ->+ let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply+ in hBox [ replyArrow+ , addEllipsis $ renderMessage MessageData+ { mdMessage = msgWithoutParent+ , mdUserName = msgWithoutParent^.mUser.to (printableNameForUserRef st)+ , mdParentMessage = Nothing+ , mdParentUserName = Nothing+ , mdHighlightSet = hs+ , mdEditThreshold = Nothing+ , mdShowOlderEdits = False+ , mdRenderReplyParent = True+ , mdRenderReplyIndent = True+ , mdIndentBlocks = False+ , mdThreadState = NoThread+ , mdShowReactions = True+ , mdMessageWidthLimit = Nothing+ , mdMyUsername = myUsername st+ , mdMyUserId = myUserId st+ , mdWrapNonhighlightedCodeBlocks = True+ , mdTruncateVerbatimBlocks = Nothing+ , mdClickableNameTag = getName editor+ }+ ]+ _ -> emptyWidget++ kc = st^.csResources.crConfiguration.configUserKeysL+ multiLineToggleKey = ppBinding $ firstActiveBinding kc ToggleMultiLineEvent++ commandBox = case st^.which.esEphemeral.eesMultiline of+ False ->+ let linesStr = "line" <> if numLines == 1 then "" else "s"+ numLines = length curContents+ in vLimit 1 $ hBox $+ prompt : if multilineContent+ then [ withDefAttr clientEmphAttr $+ str $ "[" <> show numLines <> " " <> linesStr <>+ "; Enter: send, " <> T.unpack multiLineToggleKey <>+ ": edit, Backspace: cancel] "+ , txt $ head curContents+ , showCursor (getName editor) (Location (0,0)) $ str " "+ ]+ else [inputBox]+ True -> vLimit multilineHeightLimit inputBox <=> multilineHints+ in replyDisplay <=> commandBox++drawEditorContents :: ChatState+ -> SimpleGetter ChatState (EditState Name)+ -> HighlightSet+ -> [Text]+ -> Widget Name+drawEditorContents st editWhich hs =+ let noHighlight = txt . T.unlines+ ms = st^.editWhich.esMisspellings+ in case S.null ms of+ True -> noHighlight+ False -> doHighlightMisspellings hs ms++replyArrow :: Widget a+replyArrow =+ Widget Fixed Fixed $ do+ ctx <- getContext+ let bs = ctx^.ctxBorderStyleL+ render $ str [' ', bsCornerTL bs, '▸']++-- | Tokens in spell check highlighting.+data Token =+ Ignore Text+ -- ^ This bit of text is to be ignored for the purposes of+ -- spell-checking.+ | Check Text+ -- ^ This bit of text should be checked against the spell checker's+ -- misspelling list.+ deriving (Show)++-- | This function takes a set of misspellings from the spell+-- checker, the editor lines, and builds a rendering of the text with+-- misspellings highlighted.+--+-- This function processes each line of text from the editor as follows:+--+-- * Tokenize the line based on our rules for what constitutes+-- whitespace. We do this because we need to check "words" in the+-- user's input against the list of misspellings returned by the spell+-- checker. But to do this we need to ignore the same things that+-- Aspell ignores, and it ignores whitespace and lots of puncutation.+-- We also do this because once we have identified the misspellings+-- present in the input, we need to reconstruct the user's input and+-- that means preserving whitespace so that the input looks as it was+-- originally typed.+--+-- * Once we have a list of tokens -- the whitespace tokens to be+-- preserved but ignored and the tokens to be checked -- we check+-- each non-whitespace token for presence in the list of misspellings+-- reported by the checker.+--+-- * Having indicated which tokens correspond to misspelled words, we+-- then need to coallesce adjacent tokens that are of the same+-- "misspelling status", i.e., two neighboring tokens (of whitespace+-- or check type) need to be coallesced if they both correspond to+-- text that is a misspelling or if they both are NOT a misspelling.+-- We do this so that the final Brick widget is optimal in that it+-- uses a minimal number of box cells to display substrings that have+-- the same attribute.+--+-- * Finally we build a widget out of these coallesced tokens and apply+-- the misspellingAttr attribute to the misspelled tokens.+--+-- Note that since we have to come to our own conclusion about which+-- words are worth checking in the checker's output, sometimes our+-- algorithm will differ from aspell in what is considered "part of a+-- word" and what isn't. In particular, Aspell is smart about sometimes+-- noticing that "'" is an apostrophe and at other times that it is+-- a single quote as part of a quoted string. As a result there will+-- be cases where Markdown formatting characters interact poorly+-- with Aspell's checking to result in misspellings that are *not*+-- highlighted.+--+-- One way to deal with this would be to *not* parse the user's input+-- as done here, complete with all its Markdown metacharacters, but to+-- instead 1) parse the input as Markdown, 2) traverse the Markdown AST+-- and extract the words from the relevant subtrees, and 3) spell-check+-- those words. The reason we don't do it that way in the first place is+-- because 1) the user's input might not be valid markdown and 2) even+-- if we did that, we'd still have to do this tokenization operation to+-- annotate misspellings and reconstruct the user's raw input.+doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name+doHighlightMisspellings hs misspellings contents =+ -- Traverse the input, gathering non-whitespace into tokens and+ -- checking if they appear in the misspelling collection+ let whitelist = S.union (hUserSet hs) (hChannelSet hs)++ handleLine t | t == "" = txt " "+ handleLine t =+ -- For annotated tokens, coallesce tokens of the same type+ -- and add attributes for misspellings.+ let mkW (Left tok) =+ let s = getTokenText tok+ in if T.null s+ then emptyWidget+ else withDefAttr misspellingAttr $ txt $ getTokenText tok+ mkW (Right tok) =+ let s = getTokenText tok+ in if T.null s+ then emptyWidget+ else txt s++ go :: Either Token Token -> [Either Token Token] -> [Either Token Token]+ go lst [] = [lst]+ go lst (tok:toks) =+ case (lst, tok) of+ (Left a, Left b) -> go (Left $ combineTokens a b) toks+ (Right a, Right b) -> go (Right $ combineTokens a b) toks+ _ -> lst : go tok toks++ in hBox $ mkW <$> (go (Right $ Ignore "") $ annotatedTokens t)++ combineTokens (Ignore a) (Ignore b) = Ignore $ a <> b+ combineTokens (Check a) (Check b) = Check $ a <> b+ combineTokens (Ignore a) (Check b) = Check $ a <> b+ combineTokens (Check a) (Ignore b) = Check $ a <> b++ getTokenText (Ignore a) = a+ getTokenText (Check a) = a++ annotatedTokens t =+ -- For every token, check on whether it is a misspelling.+ -- The result is Either Token Token where the Left is a+ -- misspelling and the Right is not.+ checkMisspelling <$> tokenize t (Ignore "")++ checkMisspelling t@(Ignore _) = Right t+ checkMisspelling t@(Check s) =+ if s `S.member` whitelist+ then Right t+ else if s `S.member` misspellings+ then Left t+ else Right t++ ignoreChar c = isSpace c || isPunctuation c || c == '`' || c == '/' ||+ T.singleton c == userSigil || T.singleton c == normalChannelSigil++ tokenize t curTok+ | T.null t = [curTok]+ | ignoreChar $ T.head t =+ case curTok of+ Ignore s -> tokenize (T.tail t) (Ignore $ s <> (T.singleton $ T.head t))+ Check s -> Check s : tokenize (T.tail t) (Ignore $ T.singleton $ T.head t)+ | otherwise =+ case curTok of+ Ignore s -> Ignore s : tokenize (T.tail t) (Check $ T.singleton $ T.head t)+ Check s -> tokenize (T.tail t) (Check $ s <> (T.singleton $ T.head t))++ in vBox $ handleLine <$> contents++drawSaveAttachmentWindow :: ChatState+ -> Lens' ChatState (MessageInterface Name i)+ -> Widget Name+drawSaveAttachmentWindow st which =+ center $+ padAll 2 $+ borderWithLabel (withDefAttr clientEmphAttr $ txt "Save Attachment") $+ vBox [ padAll 1 $+ txt "Path: " <+>+ (vLimit editorHeight $+ withFocusRing foc (renderEditor drawEditorTxt) ed)+ , hBox [ padRight Max $+ padLeft (Pad 1) $+ drawButton foc (AttachmentPathSaveButton listName) "Save"+ , padRight (Pad 1) $+ drawButton foc (AttachmentPathCancelButton listName) "Cancel"+ ]+ ]+ where+ editorHeight = 1+ listName = getName $ st^.which.miUrlList.ulList+ foc = st^.which.miSaveAttachmentDialog.attachmentPathDialogFocus+ ed = st^.which.miSaveAttachmentDialog.attachmentPathEditor+ drawEditorTxt = txt . T.unlines++drawUrlSelectWindow :: ChatState -> HighlightSet -> Lens' ChatState (MessageInterface Name i) -> Widget Name+drawUrlSelectWindow st hs which =+ vBox [ renderUrlList st hs which+ , urlSelectBottomBar st which+ , urlSelectInputArea st which+ ]++renderUrlList :: ChatState -> HighlightSet -> Lens' ChatState (MessageInterface Name i) -> Widget Name+renderUrlList st hs which =+ urlDisplay+ where+ urlDisplay = if F.length urls == 0+ then str "No links found." <=> fill ' '+ else renderList renderItem True urls++ urls = st^.which.miUrlList.ulList++ me = myUsername st++ renderItem sel (i, link) =+ let time = link^.linkTime+ in attr sel $ vLimit 2 $+ (vLimit 1 $+ hBox [ let u = maybe "<server>" id (link^.linkUser.to (printableNameForUserRef st))+ in colorUsername me u u+ , case link^.linkLabel of+ Nothing -> emptyWidget+ Just label ->+ case Seq.null (unInlines label) of+ True -> emptyWidget+ False -> txt ": " <+> renderRichText me hs Nothing False Nothing Nothing+ (Blocks $ Seq.singleton $ Para label)+ , fill ' '+ , renderDate st $ withServerTime time+ , str " "+ , renderTime st $ withServerTime time+ ] ) <=>+ (vLimit 1 (clickable (ClickableURLListEntry i (link^.linkTarget)) $ renderLinkTarget (link^.linkTarget)))++ renderLinkTarget (LinkPermalink (TeamURLName tName) pId) =+ renderText $ "Team: " <> tName <> ", post " <> idString pId+ renderLinkTarget (LinkURL url) = renderText $ unURL url+ renderLinkTarget (LinkFileId _) = txt " "++ attr True = forceAttr urlListSelectedAttr+ attr False = id++urlSelectBottomBar :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name+urlSelectBottomBar st which =+ case listSelectedElement $ st^.which.miUrlList.ulList of+ Nothing -> hBorder+ Just (_, (_, link)) ->+ let options = [ ( isFile+ , ev SaveAttachmentEvent+ , "save attachment"+ )+ ]+ ev = keyEventBindings st (urlSelectKeybindings which)+ isFile entry = case entry^.linkTarget of+ LinkFileId {} -> True+ _ -> False+ optionList = hBox $ intersperse (txt " ") usableOptions+ usableOptions = catMaybes $ mkOption <$> options+ mkOption (f, k, desc) = if f link+ then Just $ withDefAttr urlSelectStatusAttr (txt k) <+>+ txt (":" <> desc)+ else Nothing+ in if null usableOptions+ then hBorder+ else hBox [ hLimit 1 hBorder+ , txt "["+ , txt "Options: "+ , optionList+ , txt "]"+ , hBorder+ ]++urlSelectInputArea :: ChatState -> Lens' ChatState (MessageInterface Name i) -> Widget Name+urlSelectInputArea st which =+ let getBinding = keyEventBindings st (urlSelectKeybindings which)+ in hCenter $ hBox [ withDefAttr clientEmphAttr $ txt "Enter"+ , txt ":open "+ , withDefAttr clientEmphAttr $ txt $ getBinding CancelEvent+ , txt ":close"+ ]
src/Matterhorn/Draw/Messages.hs view
@@ -69,6 +69,8 @@ -- ^ The thread state of this message. , mdRenderReplyParent :: Bool -- ^ Whether to render the parent message.+ , mdRenderReplyIndent :: Bool+ -- ^ Whether to render reply indent decorations , mdHighlightSet :: HighlightSet -- ^ The highlight set to use to highlight usernames, -- channel names, etc.@@ -93,6 +95,9 @@ , mdWrapNonhighlightedCodeBlocks :: Bool -- ^ Whether to wrap text in non-highlighted code -- blocks.+ , mdClickableNameTag :: Name+ -- ^ Used to namespace clickable extents produced by+ -- rendering this message } maxMessageHeight :: Int@@ -119,6 +124,8 @@ -> 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@@ -128,9 +135,13 @@ -- ^ The message to render -> ThreadState -- ^ The thread state in which to render the message+ -> Name+ -- ^ Clickable name tag -> Widget Name-renderSingleMessage st hs ind m threadState =- renderChatMessage st hs ind threadState (withBrackets . renderTime st . withServerTime) m+renderSingleMessage st hs renderReplyIndent ind m threadState tag =+ renderChatMessage st hs ind threadState tag+ (withBrackets . renderTime st . withServerTime)+ renderReplyIndent m renderChatMessage :: ChatState -- ^ The application state@@ -144,12 +155,17 @@ -- 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 st hs ind threadState renderTimeFunc msg =+renderChatMessage st hs ind threadState clickableNameTag renderTimeFunc renderReplyIndent msg = let showOlderEdits = configShowOlderEdits config showTimestamp = configShowMessageTimestamps config config = st^.csResources.crConfiguration@@ -165,6 +181,7 @@ , mdHighlightSet = hs , mdShowOlderEdits = showOlderEdits , mdRenderReplyParent = True+ , mdRenderReplyIndent = renderReplyIndent , mdIndentBlocks = True , mdThreadState = threadState , mdShowReactions = True@@ -173,6 +190,7 @@ , mdMyUserId = userId $ myUser st , mdWrapNonhighlightedCodeBlocks = True , mdTruncateVerbatimBlocks = st^.csVerbatimTruncateSetting+ , mdClickableNameTag = clickableNameTag } fullMsg = case msg^.mUser of@@ -212,23 +230,25 @@ ) -- ^ The message to render, the messages -- before it, and after it, respectively- -> (Message -> ThreadState -> Widget Name)+ -> (Message -> ThreadState -> Name -> Widget Name) -- ^ A per-message rendering function to -- use+ -> Name+ -- ^ Clickable name tag -> Widget Name-unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender =+unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender tag = Widget Greedy Greedy $ do ctx <- getContext curMsgResult <- withReaderT relaxHeight $ render $ forceAttr messageSelectAttr $- padRight Max $ doMsgRender curMsg curThreadState+ padRight Max $ doMsgRender curMsg curThreadState tag let targetHeight = ctx^.availHeightL upperHeight = targetHeight `div` 2 lowerHeight = targetHeight - upperHeight - lowerHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) vLimit after- upperHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) cropTopTo before+ lowerHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) vLimit tag after+ upperHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) cropTopTo tag before let upperHalfResultsHeight = sum $ (V.imageHeight . image) <$> upperHalfResults lowerHalfResultsHeight = sum $ (V.imageHeight . image) <$> lowerHalfResults@@ -258,31 +278,34 @@ renderMessageSeq :: (SeqDirection dir) => Int- -> (Message -> ThreadState -> Widget Name)+ -> (Message -> ThreadState -> Name -> Widget Name) -> (Int -> Widget Name -> Widget Name)+ -> Name -> DirectionalSeq dir (Message, ThreadState) -> RenderM Name [Result Name]-renderMessageSeq remainingHeight renderFunc limitFunc ms+renderMessageSeq remainingHeight renderFunc limitFunc tag ms | messagesLength ms == 0 = return [] | otherwise = do let (m, threadState) = fromJust $ messagesHead ms maybeCache = case m^.mMessageId of Nothing -> id Just i -> cached (RenderedMessage i)- result <- render $ limitFunc remainingHeight $ maybeCache $ renderFunc m threadState- rest <- renderMessageSeq (remainingHeight - (V.imageHeight $ result^.imageL)) renderFunc limitFunc (messagesDrop 1 ms)+ result <- render $ limitFunc remainingHeight $ maybeCache $ renderFunc m threadState tag+ rest <- renderMessageSeq (remainingHeight - (V.imageHeight $ result^.imageL)) renderFunc limitFunc tag (messagesDrop 1 ms) return $ result : rest renderLastMessages :: ChatState -> HighlightSet -> Maybe ServerTime+ -> Bool+ -> Name -> DirectionalSeq Retrograde (Message, ThreadState) -> Widget Name-renderLastMessages st hs editCutoff msgs =+renderLastMessages st hs editCutoff renderReplyIndent tag msgs = Widget Greedy Greedy $ do ctx <- getContext let targetHeight = ctx^.availHeightL- doMsgRender = renderSingleMessage st hs editCutoff+ doMsgRender = renderSingleMessage st hs renderReplyIndent editCutoff newMessagesTransitions = filterMessages (isNewMessagesTransition . fst) msgs newMessageTransition = fst <$> (listToMaybe $ F.toList newMessagesTransitions)@@ -295,7 +318,7 @@ let (m, threadState) = fromJust $ messagesHead ms newMessagesAbove = maybe False (isBelow m) newMessageTransition - result <- render $ render1 doMsgRender m threadState+ result <- render $ render1 doMsgRender m threadState tag croppedResult <- render $ cropTopTo remainingHeight $ resultToWidget result @@ -327,17 +350,18 @@ relaxHeight :: Context n -> Context n relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL)) -render1 :: (Message -> ThreadState -> Widget Name)+render1 :: (Message -> ThreadState -> Name -> Widget Name) -> Message -> ThreadState+ -> Name -> Widget Name-render1 doMsgRender msg threadState = case msg^.mDeleted of+render1 doMsgRender msg threadState tag = case msg^.mDeleted of True -> emptyWidget False -> Widget Greedy Fixed $ do withReaderT relaxHeight $ render $ padRight Max $- doMsgRender msg threadState+ doMsgRender msg threadState tag -- | This performs rendering of the specified message according to -- settings in MessageData.@@ -359,7 +383,7 @@ Nothing -> id -- We use the index (-1) since indexes for clickable -- usernames elsewhere in this message start at 0.- Just i -> clickable (ClickableUsernameInMessage i (-1) un)+ Just i -> clickable (ClickableUsername (Just i) mdClickableNameTag (-1) un) nameElems = case msgUsr of Just un@@ -399,16 +423,21 @@ replyIndent = Widget Fixed Fixed $ do ctx <- getContext- -- NB: The amount subtracted here must be the total padding- -- added below (pad 1 + vBorder)- w <- render $ hLimit (ctx^.availWidthL - 2) msgWidget- render $ vLimit (V.imageHeight $ w^.imageL) $- padRight (Pad 1) vBorder <+> resultToWidget w+ w <- case mdRenderReplyIndent of+ True -> do+ -- NB: The amount subtracted here must be the total+ -- padding added below (pad 1 + vBorder)+ w <- render $ hLimit (ctx^.availWidthL - 2) msgWidget+ return $ vLimit (V.imageHeight $ w^.imageL) $+ padRight (Pad 1) vBorder <+> resultToWidget w+ False ->+ return msgWidget+ render w msgAtch = if S.null (msg^.mAttachments) then Nothing else Just $ withDefAttr clientMessageAttr $ vBox- [ padLeft (Pad 2) $ clickable (ClickableAttachment (a^.attachmentFileId)) $+ [ padLeft (Pad 2) $ clickable (ClickableAttachmentInMessage mdClickableNameTag (a^.attachmentFileId)) $ txt ("[attached: `" <> a^.attachmentName <> "`]") | a <- toList (msg^.mAttachments) ]@@ -419,7 +448,8 @@ InThreadShowParent -> p <=> replyIndent InThread -> replyIndent - in if not mdRenderReplyParent+ in freezeBorders $+ if not mdRenderReplyParent then msgWidget else case msg^.mInReplyToMsg of NotAReply -> msgWidget@@ -455,7 +485,7 @@ , hBox [txt " ", renderRichText mdMyUsername hs ((subtract 2) <$> w) mdWrapNonhighlightedCodeBlocks mdTruncateVerbatimBlocks- (Just (mkClickableInline (msg^.mMessageId) Nothing)) (Blocks bs)]+ (Just (mkClickableInline (msg^.mMessageId) mdClickableNameTag)) (Blocks bs)] ] else nameNextToMessage hs w nameElems bs @@ -467,22 +497,18 @@ , renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks mdTruncateVerbatimBlocks- (Just (mkClickableInline (msg^.mMessageId) Nothing)) (Blocks bs)+ (Just (mkClickableInline (msg^.mMessageId) mdClickableNameTag)) (Blocks bs) ] isBreak i = i `elem` [ELineBreak, ESoftBreak] -mkClickableInline :: Maybe MessageId -> Maybe Name -> Int -> Inline -> Maybe Name-mkClickableInline mmId _ i (EHyperlink u _) = do- mId <- mmId- return $ ClickableURLInMessage mId i $ LinkURL u-mkClickableInline mmId _ i (EUser name) = do- mId <- mmId- return $ ClickableUsernameInMessage mId i name-mkClickableInline (Just mId) _ i (EPermalink teamUrlName pId _) =- return $ ClickableURLInMessage mId i $ LinkPermalink teamUrlName pId-mkClickableInline Nothing (Just scope) i (EPermalink teamUrlName pId _) =- return $ ClickableURL scope i $ LinkPermalink teamUrlName pId+mkClickableInline :: Maybe MessageId -> Name -> Int -> Inline -> Maybe Name+mkClickableInline mmId scope i (EHyperlink u _) = do+ return $ ClickableURL mmId scope i $ LinkURL u+mkClickableInline mmId scope i (EUser name) =+ return $ ClickableUsername mmId scope i name+mkClickableInline mmId scope i (EPermalink teamUrlName pId _) =+ return $ ClickableURL mmId scope i $ LinkPermalink teamUrlName pId mkClickableInline _ _ _ _ = Nothing @@ -506,7 +532,7 @@ hasAnyReactions = not $ null nonEmptyReactions makeName e us = do pid <- postId <$> msg^.mOriginalPost- Just $ ClickableReactionInMessage pid e us+ Just $ ClickableReaction pid mdClickableNameTag e us reactionWidget = Widget Fixed Fixed $ do ctx <- getContext let lineW = ctx^.availWidthL
− src/Matterhorn/Draw/PostListOverlay.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module Matterhorn.Draw.PostListOverlay where--import Prelude ()-import Matterhorn.Prelude--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center-import Control.Monad.Trans.Reader ( withReaderT )-import qualified Data.Text as T-import Lens.Micro.Platform ( (%~), to )--import Network.Mattermost.Lenses-import Network.Mattermost.Types--import Matterhorn.Draw.Messages-import Matterhorn.Draw.Util-import Matterhorn.Themes-import Matterhorn.Types---hLimitWithPadding :: Int -> Widget n -> Widget n-hLimitWithPadding pad contents = Widget- { hSize = Fixed- , vSize = (vSize contents)- , render =- withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents- }--drawPostListOverlay :: PostListContents -> ChatState -> TeamId -> Widget Name-drawPostListOverlay contents st tId = joinBorders $ drawPostsBox contents st tId---- | Draw a PostListOverlay as a floating overlay on top of whatever--- is rendered beneath it-drawPostsBox :: PostListContents -> ChatState -> TeamId -> Widget Name-drawPostsBox contents st tId =- centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $- padRight (Pad 1) messageListContents- where -- The 'window title' of the overlay- hs = getHighlightSet st tId- contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of- PostListFlagged -> "Flagged posts"- PostListPinned cId ->- let cName = case findChannelById cId (st^.csChannels) of- Nothing -> "<UNKNOWN>"- Just cc -> mkChannelName st (cc^.ccInfo)- in "Posts pinned in " <> cName- PostListSearch terms searching -> "Search results" <> if searching- then ": " <> terms- else " (" <> (T.pack . show . length) entries <> "): " <> terms-- entries = filterMessages knownChannel $ st^.csTeam(tId).tsPostListOverlay.postListPosts- messages = insertDateMarkers- entries- (getDateFormat st)- (st^.timeZone)-- knownChannel msg =- case msg^.mChannelId of- Just cId | Nothing <- st^?csChannels.channelByIdL(cId) -> False- _ -> True-- -- The overall contents, with a sensible default even if there- -- are no messages- messageListContents- | null messages =- padTopBottom 1 $- hCenter $- withDefAttr clientEmphAttr $- str $ case contents of- PostListFlagged -> "You have no flagged messages."- PostListPinned _ -> "This channel has no pinned messages."- PostListSearch _ searching ->- if searching- then "Searching ..."- else "No search results found"- | otherwise = vBox renderedMessageList-- -- The render-message function we're using- renderMessageForOverlay msg tState =- let renderedMsg = renderSingleMessage st hs Nothing msg tState- in case msg^.mOriginalPost of- -- We should factor out some of the channel name logic at- -- some point, but we can do that later- Just post- | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) ->- case chan^.ccInfo.cdType of- Direct- | Just u <- flip userById st =<< chan^.ccInfo.cdDMUserId ->- (forceAttr channelNameAttr (txt (addUserSigil $ u^.uiName)) <=>- (str " " <+> renderedMsg))- _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to (mkChannelName st))) <=>- (str " " <+> renderedMsg))- _ | CP _ <- msg^.mType -> str "[BUG: unknown channel]"- | otherwise -> renderedMsg-- -- The full message list, rendered with the current selection- renderedMessageList =- let (s, (before, after)) = splitDirSeqOn matchesMessage messagesWithStates- matchesMessage (m, _) = m^.mMessageId == (MessagePostId <$> st^.csTeam(tId).tsPostListOverlay.postListSelected)- messagesWithStates = (, InThreadShowParent) <$> messages- in case s of- Nothing ->- map (uncurry renderMessageForOverlay) (toList messagesWithStates)- Just curMsg ->- [unsafeRenderMessageSelection (curMsg, (before, after)) renderMessageForOverlay]
+ src/Matterhorn/Draw/PostListWindow.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Matterhorn.Draw.PostListWindow where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Control.Monad.Trans.Reader ( withReaderT )+import qualified Data.Text as T+import Lens.Micro.Platform ( (%~), to )++import Network.Mattermost.Lenses+import Network.Mattermost.Types++import Matterhorn.Draw.Messages+import Matterhorn.Draw.Util+import Matterhorn.Themes+import Matterhorn.Types+++hLimitWithPadding :: Int -> Widget n -> Widget n+hLimitWithPadding pad contents = Widget+ { hSize = Fixed+ , vSize = (vSize contents)+ , render =+ withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents+ }++drawPostListWindow :: PostListContents -> ChatState -> TeamId -> Widget Name+drawPostListWindow contents st tId = joinBorders $ drawPostsBox contents st tId++-- | Draw a PostListWindow as a floating window on top of whatever+-- is rendered beneath it+drawPostsBox :: PostListContents -> ChatState -> TeamId -> Widget Name+drawPostsBox contents st tId =+ centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $+ padRight (Pad 1) messageListContents+ where -- The 'window title' of the window+ hs = getHighlightSet st tId+ contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of+ PostListFlagged -> "Flagged posts"+ PostListPinned cId ->+ let cName = case findChannelById cId (st^.csChannels) of+ Nothing -> "<UNKNOWN>"+ Just cc -> mkChannelName st (cc^.ccInfo)+ in "Posts pinned in " <> cName+ PostListSearch terms searching -> "Search results" <> if searching+ then ": " <> terms+ else " (" <> (T.pack . show . length) entries <> "): " <> terms++ entries = filterMessages knownChannel $ st^.csTeam(tId).tsPostListWindow.postListPosts+ messages = insertDateMarkers+ entries+ (getDateFormat st)+ (st^.timeZone)++ knownChannel msg =+ case msg^.mChannelId of+ Just cId | Nothing <- st^?csChannels.channelByIdL(cId) -> False+ _ -> True++ -- The overall contents, with a sensible default even if there+ -- are no messages+ messageListContents+ | null messages =+ padTopBottom 1 $+ hCenter $+ withDefAttr clientEmphAttr $+ str $ case contents of+ PostListFlagged -> "You have no flagged messages."+ PostListPinned _ -> "This channel has no pinned messages."+ PostListSearch _ searching ->+ if searching+ then "Searching ..."+ else "No search results found"+ | otherwise = vBox renderedMessageList++ -- The render-message function we're using+ renderMessageForWindow msg tState tag =+ let renderedMsg = renderSingleMessage st hs True Nothing msg tState tag+ in case msg^.mOriginalPost of+ -- We should factor out some of the channel name logic at+ -- some point, but we can do that later+ Just post+ | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) ->+ case chan^.ccInfo.cdType of+ Direct+ | Just u <- flip userById st =<< chan^.ccInfo.cdDMUserId ->+ (forceAttr channelNameAttr (txt (addUserSigil $ u^.uiName)) <=>+ (str " " <+> renderedMsg))+ _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to (mkChannelName st))) <=>+ (str " " <+> renderedMsg))+ _ | CP _ <- msg^.mType -> str "[BUG: unknown channel]"+ | otherwise -> renderedMsg++ -- The full message list, rendered with the current selection+ renderedMessageList =+ let (s, (before, after)) = splitDirSeqOn matchesMessage messagesWithStates+ matchesMessage (m, _) = m^.mMessageId == (MessagePostId <$> st^.csTeam(tId).tsPostListWindow.postListSelected)+ messagesWithStates = (, InThreadShowParent) <$> messages+ tag = PostList+ in case s of+ Nothing ->+ map (\(m, tst) -> renderMessageForWindow m tst tag) (toList messagesWithStates)+ Just curMsg ->+ [unsafeRenderMessageSelection (curMsg, (before, after)) renderMessageForWindow tag]
− src/Matterhorn/Draw/ReactionEmojiListOverlay.hs
@@ -1,42 +0,0 @@-module Matterhorn.Draw.ReactionEmojiListOverlay- ( drawReactionEmojiListOverlay- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import Brick.Widgets.List ( listSelectedFocusedAttr )-import qualified Data.Text as T--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import Matterhorn.Types-import Matterhorn.Themes---drawReactionEmojiListOverlay :: ChatState -> TeamId -> Widget Name-drawReactionEmojiListOverlay st tId =- let overlay = drawListOverlay (st^.csTeam(tId).tsReactionEmojiListOverlay)- (const $ txt "Search Emoji")- (const $ txt "No matching emoji found.")- (const $ txt "Search emoji:")- renderEmoji- Nothing- OverlayCenter- 80- in joinBorders overlay--renderEmoji :: Bool -> (Bool, T.Text) -> Widget Name-renderEmoji sel (mine, e) =- let maybeForce = if sel- then forceAttr listSelectedFocusedAttr- else id- in clickable (ReactionEmojiListOverlayEntry (mine, e)) $- maybeForce $- padRight Max $- hBox [ if mine then txt " * " else txt " "- , withDefAttr emojiAttr $ txt $ ":" <> e <> ":"- ]
+ src/Matterhorn/Draw/ReactionEmojiListWindow.hs view
@@ -0,0 +1,42 @@+module Matterhorn.Draw.ReactionEmojiListWindow+ ( drawReactionEmojiListWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.List ( listSelectedFocusedAttr )+import qualified Data.Text as T++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Draw.ListWindow ( drawListWindow, WindowPosition(..) )+import Matterhorn.Types+import Matterhorn.Themes+++drawReactionEmojiListWindow :: ChatState -> TeamId -> Widget Name+drawReactionEmojiListWindow st tId =+ let window = drawListWindow (st^.csTeam(tId).tsReactionEmojiListWindow)+ (const $ txt "Search Emoji")+ (const $ txt "No matching emoji found.")+ (const $ txt "Search emoji:")+ renderEmoji+ Nothing+ WindowCenter+ 80+ in joinBorders window++renderEmoji :: Bool -> (Bool, T.Text) -> Widget Name+renderEmoji sel (mine, e) =+ let maybeForce = if sel+ then forceAttr listSelectedFocusedAttr+ else id+ in clickable (ClickableReactionEmojiListWindowEntry (mine, e)) $+ maybeForce $+ padRight Max $+ hBox [ if mine then txt " * " else txt " "+ , withDefAttr emojiAttr $ txt $ ":" <> e <> ":"+ ]
− src/Matterhorn/Draw/SaveAttachmentWindow.hs
@@ -1,46 +0,0 @@-module Matterhorn.Draw.SaveAttachmentWindow- ( drawSaveAttachmentWindow- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import Brick.Focus-import Brick.Widgets.Border-import Brick.Widgets.Center-import Brick.Widgets.Edit--import qualified Data.Text as T--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Types-import Matterhorn.Draw.Buttons-import Matterhorn.Themes---drawSaveAttachmentWindow :: ChatState -> TeamId -> Widget Name-drawSaveAttachmentWindow st tId =- centerLayer $- hLimit maxWindowWidth $- joinBorders $- borderWithLabel (withDefAttr clientEmphAttr $ txt "Save Attachment") $- vBox [ padAll 1 $- txt "Path: " <+>- (vLimit editorHeight $- withFocusRing foc (renderEditor drawEditorTxt) ed)- , hBox [ padRight Max $- padLeft (Pad 1) $- drawButton foc (AttachmentPathSaveButton tId) "Save"- , padRight (Pad 1) $- drawButton foc (AttachmentPathCancelButton tId) "Cancel"- ]- ]- where- editorHeight = 1- maxWindowWidth = 50- foc = st^.csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus- ed = st^.csTeam(tId).tsSaveAttachmentDialog.attachmentPathEditor- drawEditorTxt = txt . T.unlines
src/Matterhorn/Draw/ShowHelp.hs view
@@ -30,13 +30,14 @@ import Matterhorn.Events.Global import Matterhorn.Events.Main import Matterhorn.Events.MessageSelect-import Matterhorn.Events.ThemeListOverlay-import Matterhorn.Events.PostListOverlay+import Matterhorn.Events.MessageInterface+import Matterhorn.Events.ThemeListWindow+import Matterhorn.Events.PostListWindow import Matterhorn.Events.ShowHelp import Matterhorn.Events.UrlSelect-import Matterhorn.Events.UserListOverlay-import Matterhorn.Events.ChannelListOverlay-import Matterhorn.Events.ReactionEmojiListOverlay+import Matterhorn.Events.UserListWindow+import Matterhorn.Events.ChannelListWindow+import Matterhorn.Events.ReactionEmojiListWindow import Matterhorn.Events.ManageAttachments import Matterhorn.Events.TabbedWindow import Matterhorn.Windows.ViewMessage@@ -52,7 +53,7 @@ drawShowHelp :: HelpTopic -> ChatState -> [Widget Name] drawShowHelp topic st =- [helpBox (helpTopicViewportName topic) $ helpTopicDraw topic st]+ [helpBox (helpTopicScreen topic) $ helpTopicDraw topic st] helpTopicDraw :: HelpTopic -> ChatState -> Widget Name helpTopicDraw topic st =@@ -83,7 +84,8 @@ mkCommandHelpText :: Widget Name mkCommandHelpText = let commandNameWidth = 2 + (maximum $ T.length <$> fst <$> commandHelpInfo)- in vBox [ (emph $ txt $ padTo commandNameWidth info) <+> renderText desc+ in vBox [ (emph $ txt $ padTo commandNameWidth info) <=>+ (padBottom (Pad 1) $ padLeft (Pad 2) $ renderText desc) | (info, desc) <- commandHelpInfo ] @@ -114,10 +116,13 @@ , "| Command | Description |" , "| ------- | ----------- |" ] <>- [ "| `" <> info <> "` | " <> desc <> " |"+ [ "| `" <> escapePipes info <> "` | " <> escapePipes desc <> " |" | (info, desc) <- commandHelpInfo ] +escapePipes :: Text -> Text+escapePipes = T.replace "|" "\\|"+ drawHelpTopics :: Widget Name drawHelpTopics = let allHelpTopics = drawTopic <$> helpTopics@@ -287,6 +292,9 @@ ] ] +event :: KeyEvent -> Widget a+event = withDefAttr helpKeyEventAttr . txt . keyEventName+ emph :: Widget a -> Widget a emph = withDefAttr helpEmphAttr @@ -445,37 +453,42 @@ keybindSections = [ ("Global Keybindings", globalKeyHandlers) , ("Help Page", helpKeyHandlers teamIdThunk)- , ("Main Interface", mainKeyHandlers teamIdThunk)- , ("Text Editing", editingKeyHandlers teamIdThunk editorThunk)+ , ("Main Interface", mainKeyHandlers teamIdThunk <>+ messageInterfaceKeyHandlers whichThunk)+ , ("Message Editing", extraEditorKeyHandlers whichThunk)+ , ("Text Editing", editingKeyHandlers editorThunk) , ("Channel Select Mode", channelSelectKeyHandlers teamIdThunk)- , ("Message Select Mode", messageSelectKeyHandlers teamIdThunk)- , ("User Listings", userListOverlayKeyHandlers teamIdThunk)- , ("URL Select Mode", urlSelectKeyHandlers teamIdThunk)- , ("Theme List Window", themeListOverlayKeyHandlers teamIdThunk)- , ("Channel Search Window", channelListOverlayKeyHandlers teamIdThunk)+ , ("Message Select Mode", messageSelectKeyHandlers teamIdThunk whichThunk)+ , ("User Listings", userListWindowKeyHandlers teamIdThunk)+ , ("URL Select Mode", urlSelectKeyHandlers whichThunk)+ , ("Theme List Window", themeListWindowKeyHandlers teamIdThunk)+ , ("Channel Search Window", channelListWindowKeyHandlers teamIdThunk) , ("Message Viewer: Common", tabbedWindowKeyHandlers teamIdThunk tabbedWinThunk) , ("Message Viewer: Message tab", viewMessageKeyHandlers teamIdThunk) , ("Message Viewer: Reactions tab", viewMessageReactionsKeyHandlers teamIdThunk)- , ("Attachment List", attachmentListKeyHandlers teamIdThunk)- , ("Attachment File Browser", attachmentBrowseKeyHandlers teamIdThunk)- , ("Flagged Messages", postListOverlayKeyHandlers teamIdThunk)- , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeyHandlers teamIdThunk)+ , ("Attachment List", attachmentListKeyHandlers whichThunk)+ , ("Attachment File Browser", attachmentBrowseKeyHandlers whichThunk)+ , ("Flagged Messages", postListWindowKeyHandlers teamIdThunk)+ , ("Reaction Emoji Search Window", reactionEmojiListWindowKeyHandlers teamIdThunk) ] teamIdThunk :: TeamId teamIdThunk = error "BUG: should not evaluate teamIdThunk" -tabbedWinThunk :: Lens' ChatState (TabbedWindow Int)+tabbedWinThunk :: Lens' ChatState (TabbedWindow ChatState MH Name Int) tabbedWinThunk = error "BUG: should not evaluate tabbedWinThunk" editorThunk :: Lens' ChatState (Editor Text Name) editorThunk = error "BUG: should not evaluate editorThunk" -helpBox :: Name -> Widget Name -> Widget Name-helpBox n helpText =+whichThunk :: Lens' ChatState (MessageInterface n i)+whichThunk = error "BUG: should not evaluate whichThunk"++helpBox :: HelpScreen -> Widget Name -> Widget Name+helpBox scr helpText = withDefAttr helpAttr $ viewport HelpViewport Vertical $- cached n helpText+ cached (HelpContent scr) helpText kbColumnWidth :: Int kbColumnWidth = 14@@ -493,8 +506,8 @@ mkKeybindHelp :: KeyConfig -> KeyEventHandler -> (Text, Widget Name) mkKeybindHelp kc h = let unbound = ["(unbound)"]- label = case kehEventTrigger h of- Static k -> ppBinding $ eventToBinding k+ (label, mEv) = case kehEventTrigger h of+ Static k -> (ppBinding $ eventToBinding k, Nothing) ByEvent ev -> let bindings = case M.lookup ev kc of Nothing ->@@ -505,12 +518,18 @@ Just Unbound -> unbound Just (BindingList bs) | not (null bs) -> ppBinding <$> bs | otherwise -> unbound- in T.intercalate ", " bindings+ in (T.intercalate ", " bindings, Just ev) + renderEvent ev = txt "event: " <+> event ev rendering = (emph $ txt $ padTo kbColumnWidth $ label) <+> txt " " <+>- (hLimit kbDescColumnWidth $ padRight Max $ renderText $- ehDescription $ kehHandler h)+ (hLimit kbDescColumnWidth $+ padRight Max $+ padBottom (Pad 1) $+ vBox [ renderText $ ehDescription $ kehHandler h+ , maybe emptyWidget renderEvent mEv+ ]+ ) in (label, rendering) mkKeybindEventSectionHelp :: KeyConfig
src/Matterhorn/Draw/TabbedWindow.hs view
@@ -21,7 +21,7 @@ -- | Render a tabbed window. drawTabbedWindow :: (Eq a, Show a)- => TabbedWindow a+ => TabbedWindow ChatState m Name a -> ChatState -> TeamId -> Widget Name@@ -47,7 +47,7 @@ -- | The scrollable tab bar to show at the top of a tabbed window. tabBar :: (Eq a, Show a) => TeamId- -> TabbedWindow a+ -> TabbedWindow s m Name a -> Widget Name tabBar tId w = let cur = getCurrentTabbedWindowEntry w
− src/Matterhorn/Draw/ThemeListOverlay.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Matterhorn.Draw.ThemeListOverlay- ( drawThemeListOverlay- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import qualified Brick.Widgets.List as L-import Brick.Widgets.Border ( hBorder )-import Brick.Widgets.Center ( hCenter )--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import Matterhorn.Themes-import Matterhorn.Types-import Matterhorn.Types.KeyEvents ( ppBinding )-import Matterhorn.Events.Keybindings---drawThemeListOverlay :: ChatState -> TeamId -> Widget Name-drawThemeListOverlay st tId =- let overlay = drawListOverlay (st^.csTeam(tId).tsThemeListOverlay)- (const $ txt "Themes")- (const $ txt "No matching themes found.")- (const $ txt "Search built-in themes:")- renderInternalTheme- (Just footer)- OverlayUpperRight- 50- footer = hBorder <=>- (hCenter $ hBox [ enter- , txt $ ":choose theme "- , close- , txt ":close"- ])- enter = emph $ txt $ ppBinding (firstActiveBinding kc ActivateListItemEvent)- close = emph $ txt $ ppBinding (firstActiveBinding kc CancelEvent)- kc = st^.csResources.crConfiguration.configUserKeysL- emph = withDefAttr clientEmphAttr- in joinBorders overlay--renderInternalTheme :: Bool -> InternalTheme -> Widget Name-renderInternalTheme foc it =- (if foc then forceAttr L.listSelectedFocusedAttr else id) $- (padRight Max $- withDefAttr clientEmphAttr $- txt $ internalThemeName it) <=>- (vLimit 2 $- (padLeft (Pad 2) $ txtWrap $ internalThemeDesc it) <=> fill ' ')
+ src/Matterhorn/Draw/ThemeListWindow.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Matterhorn.Draw.ThemeListWindow+ ( drawThemeListWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import qualified Brick.Widgets.List as L+import Brick.Widgets.Border ( hBorder )+import Brick.Widgets.Center ( hCenter )++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Draw.ListWindow ( drawListWindow, WindowPosition(..) )+import Matterhorn.Themes+import Matterhorn.Types+import Matterhorn.Types.KeyEvents ( ppBinding )+import Matterhorn.Events.Keybindings+++drawThemeListWindow :: ChatState -> TeamId -> Widget Name+drawThemeListWindow st tId =+ let window = drawListWindow (st^.csTeam(tId).tsThemeListWindow)+ (const $ txt "Themes")+ (const $ txt "No matching themes found.")+ (const $ txt "Search built-in themes:")+ renderInternalTheme+ (Just footer)+ WindowUpperRight+ 50+ footer = hBorder <=>+ (hCenter $ hBox [ enter+ , txt $ ":choose theme "+ , close+ , txt ":close"+ ])+ enter = emph $ txt $ ppBinding (firstActiveBinding kc ActivateListItemEvent)+ close = emph $ txt $ ppBinding (firstActiveBinding kc CancelEvent)+ kc = st^.csResources.crConfiguration.configUserKeysL+ emph = withDefAttr clientEmphAttr+ in joinBorders window++renderInternalTheme :: Bool -> InternalTheme -> Widget Name+renderInternalTheme foc it =+ (if foc then forceAttr L.listSelectedFocusedAttr else id) $+ (padRight Max $+ withDefAttr clientEmphAttr $+ txt $ internalThemeName it) <=>+ (vLimit 2 $+ (padLeft (Pad 2) $ txtWrap $ internalThemeDesc it) <=> fill ' ')
− src/Matterhorn/Draw/URLList.hs
@@ -1,80 +0,0 @@-module Matterhorn.Draw.URLList- ( renderUrlList- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import Brick.Widgets.Border ( hBorder )-import Brick.Widgets.List ( renderList )-import qualified Data.Sequence as Seq-import qualified Data.Foldable as F-import Lens.Micro.Platform ( to )--import Network.Mattermost.Types ( ServerTime(..), TeamId, idString )--import Matterhorn.Draw.Messages-import Matterhorn.Draw.Util-import Matterhorn.Draw.RichText-import Matterhorn.Themes-import Matterhorn.Types-import Matterhorn.Types.RichText---renderUrlList :: ChatState -> TeamId -> Widget Name-renderUrlList st tId =- case st^.csCurrentChannelId(tId) of- Nothing -> emptyWidget- Just cId ->- case st^?csChannel(cId) of- Nothing -> emptyWidget- Just ch -> renderUrlList' st tId ch--renderUrlList' :: ChatState -> TeamId -> ClientChannel -> Widget Name-renderUrlList' st tId chan =- header <=> urlDisplay- where- cName = mkChannelName st (chan^.ccInfo)- header = (withDefAttr channelHeaderAttr $ vLimit 1 $- (renderText' Nothing "" hSet Nothing $ "URLs: " <> cName) <+>- fill ' ') <=> hBorder-- urlDisplay = if F.length urls == 0- then str "No URLs found in this channel."- else renderList renderItem True urls-- urls = st^.csTeam(tId).tsUrlList-- me = myUsername st-- hSet = getHighlightSet st tId-- renderItem sel (i, link) =- let time = link^.linkTime- in attr sel $ vLimit 2 $- (vLimit 1 $- hBox [ let u = maybe "<server>" id (link^.linkUser.to (printableNameForUserRef st))- in colorUsername me u u- , case link^.linkLabel of- Nothing -> emptyWidget- Just label ->- case Seq.null (unInlines label) of- True -> emptyWidget- False -> txt ": " <+> renderRichText me hSet Nothing False Nothing Nothing- (Blocks $ Seq.singleton $ Para label)- , fill ' '- , renderDate st $ withServerTime time- , str " "- , renderTime st $ withServerTime time- ] ) <=>- (vLimit 1 (clickable (ClickableURLListEntry i (link^.linkTarget)) $ renderLinkTarget (link^.linkTarget)))-- renderLinkTarget (LinkPermalink (TeamURLName tName) pId) =- renderText $ "Team: " <> tName <> ", post " <> idString pId- renderLinkTarget (LinkURL url) = renderText $ unURL url- renderLinkTarget (LinkFileId _) = txt " "-- attr True = forceAttr urlListSelectedAttr- attr False = id
− src/Matterhorn/Draw/UserListOverlay.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Matterhorn.Draw.UserListOverlay- ( drawUserListOverlay- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick-import qualified Brick.Widgets.List as L-import qualified Data.Text as T-import qualified Graphics.Vty as V--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Draw.Util ( userSigilFromInfo )-import Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import Matterhorn.Themes-import Matterhorn.Types---drawUserListOverlay :: ChatState -> TeamId -> Widget Name-drawUserListOverlay st tId =- let overlay = drawListOverlay (st^.csTeam(tId).tsUserListOverlay) userSearchScopeHeader- userSearchScopeNoResults userSearchScopePrompt- (renderUser (myUsername st))- Nothing- OverlayCenter- 80- in joinBorders overlay--userSearchScopePrompt :: UserSearchScope -> Widget Name-userSearchScopePrompt scope =- txt $ case scope of- ChannelMembers _ _ -> "Search channel members:"- ChannelNonMembers _ _ -> "Search users:"- AllUsers Nothing -> "Search users:"- AllUsers (Just _) -> "Search team members:"--userSearchScopeNoResults :: UserSearchScope -> Widget Name-userSearchScopeNoResults scope =- txt $ case scope of- ChannelMembers _ _ -> "No users in channel."- ChannelNonMembers _ _ -> "All users in your team are already in this channel."- AllUsers _ -> "No users found."--userSearchScopeHeader :: UserSearchScope -> Widget Name-userSearchScopeHeader scope =- txt $ case scope of- ChannelMembers {} -> "Channel Members"- ChannelNonMembers {} -> "Invite Users to Channel"- AllUsers Nothing -> "Users On This Server"- AllUsers (Just _) -> "Users In My Team"--renderUser :: Text -> Bool -> UserInfo -> Widget Name-renderUser myUName foc ui =- (if foc then forceAttr L.listSelectedFocusedAttr else id) $- vLimit 2 $- padRight Max $- hBox $ (padRight (Pad 1) $ colorUsername myUName (ui^.uiName) (T.singleton $ userSigilFromInfo ui))- : (hLimit usernameWidth $ padRight Max $ colorUsername myUName (ui^.uiName) (ui^.uiName))- : extras- where- sanitize = T.strip . T.replace "\t" " "- usernameWidth = 20- extras = padRight (Pad 1) <$> catMaybes [mFullname, mNickname, mEmail]- mFullname = if (not (T.null (ui^.uiFirstName)) || not (T.null (ui^.uiLastName)))- then Just $ txt $ (sanitize $ ui^.uiFirstName) <> " " <> (sanitize $ ui^.uiLastName)- else Nothing- mNickname = case ui^.uiNickName of- Just n | n /= (ui^.uiName) -> Just $ txt $ "(" <> n <> ")"- _ -> Nothing- mEmail = if (T.null $ ui^.uiEmail)- then Nothing- else Just $ modifyDefAttr (`V.withURL` ("mailto:" <> ui^.uiEmail)) $- withDefAttr urlAttr (txt ("<" <> ui^.uiEmail <> ">"))
+ src/Matterhorn/Draw/UserListWindow.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Matterhorn.Draw.UserListWindow+ ( drawUserListWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import qualified Brick.Widgets.List as L+import qualified Data.Text as T+import qualified Graphics.Vty as V++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Draw.Util ( userSigilFromInfo )+import Matterhorn.Draw.ListWindow ( drawListWindow, WindowPosition(..) )+import Matterhorn.Themes+import Matterhorn.Types+++drawUserListWindow :: ChatState -> TeamId -> Widget Name+drawUserListWindow st tId =+ let window = drawListWindow (st^.csTeam(tId).tsUserListWindow) userSearchScopeHeader+ userSearchScopeNoResults userSearchScopePrompt+ (renderUser (myUsername st))+ Nothing+ WindowCenter+ 80+ in joinBorders window++userSearchScopePrompt :: UserSearchScope -> Widget Name+userSearchScopePrompt scope =+ txt $ case scope of+ ChannelMembers _ _ -> "Search channel members:"+ ChannelNonMembers _ _ -> "Search users:"+ AllUsers Nothing -> "Search users:"+ AllUsers (Just _) -> "Search team members:"++userSearchScopeNoResults :: UserSearchScope -> Widget Name+userSearchScopeNoResults scope =+ txt $ case scope of+ ChannelMembers _ _ -> "No users in channel."+ ChannelNonMembers _ _ -> "All users in your team are already in this channel."+ AllUsers _ -> "No users found."++userSearchScopeHeader :: UserSearchScope -> Widget Name+userSearchScopeHeader scope =+ txt $ case scope of+ ChannelMembers {} -> "Channel Members"+ ChannelNonMembers {} -> "Invite Users to Channel"+ AllUsers Nothing -> "Users On This Server"+ AllUsers (Just _) -> "Users In My Team"++renderUser :: Text -> Bool -> UserInfo -> Widget Name+renderUser myUName foc ui =+ (if foc then forceAttr L.listSelectedFocusedAttr else id) $+ vLimit 2 $+ padRight Max $+ hBox $ (padRight (Pad 1) $ colorUsername myUName (ui^.uiName) (T.singleton $ userSigilFromInfo ui))+ : (hLimit usernameWidth $ padRight Max $ colorUsername myUName (ui^.uiName) (ui^.uiName))+ : extras+ where+ sanitize = T.strip . T.replace "\t" " "+ usernameWidth = 20+ extras = padRight (Pad 1) <$> catMaybes [mFullname, mNickname, mEmail]+ mFullname = if (not (T.null (ui^.uiFirstName)) || not (T.null (ui^.uiLastName)))+ then Just $ txt $ (sanitize $ ui^.uiFirstName) <> " " <> (sanitize $ ui^.uiLastName)+ else Nothing+ mNickname = case ui^.uiNickName of+ Just n | n /= (ui^.uiName) -> Just $ txt $ "(" <> n <> ")"+ _ -> Nothing+ mEmail = if (T.null $ ui^.uiEmail)+ then Nothing+ else Just $ modifyDefAttr (`V.withURL` ("mailto:" <> ui^.uiEmail)) $+ withDefAttr urlAttr (txt ("<" <> ui^.uiEmail <> ">"))
src/Matterhorn/Draw/Util.hs view
@@ -8,6 +8,7 @@ , mkChannelName , userSigilFromInfo , multilineHeightLimit+ , keyEventBindings ) where @@ -16,6 +17,7 @@ import Brick import Data.List ( intersperse )+import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text as T import Network.Mattermost.Types@@ -25,7 +27,7 @@ import Matterhorn.TimeUtils import Matterhorn.Types import Matterhorn.Types.KeyEvents-import Matterhorn.Events.Keybindings ( firstActiveBinding )+import Matterhorn.Events.Keybindings defaultTimeFormat :: Text@@ -98,3 +100,27 @@ Group -> mempty Direct -> userSigil Unknown _ -> mempty++-- | Resolve the specified key event into a pretty-printed+-- representation of the active bindings for that event, using the+-- specified key handler map builder. If the event has more than one+-- active binding, the bindings are comma-delimited in the resulting+-- string.+keyEventBindings :: ChatState+ -- ^ The current application state+ -> (KeyConfig -> KeyHandlerMap)+ -- ^ The function to obtain the relevant key handler+ -- map+ -> KeyEvent+ -- ^ The key event to look up+ -> T.Text+keyEventBindings st mkBindingsMap e =+ let keyconf = st^.csResources.crConfiguration.configUserKeysL+ KeyHandlerMap keymap = mkBindingsMap keyconf+ in T.intercalate ","+ [ ppBinding (eventToBinding k)+ | KH { khKey = k+ , khHandler = h+ } <- M.elems keymap+ , kehEventTrigger h == ByEvent e+ ]
src/Matterhorn/Events.hs view
@@ -28,22 +28,19 @@ import Matterhorn.Events.ChannelSelect import Matterhorn.Events.ChannelTopicWindow-import Matterhorn.Events.SaveAttachmentWindow import Matterhorn.Events.DeleteChannelConfirm import Matterhorn.Events.Global import Matterhorn.Events.Keybindings import Matterhorn.Events.LeaveChannelConfirm import Matterhorn.Events.Main import Matterhorn.Events.MessageSelect-import Matterhorn.Events.ThemeListOverlay-import Matterhorn.Events.PostListOverlay+import Matterhorn.Events.ThemeListWindow+import Matterhorn.Events.PostListWindow import Matterhorn.Events.ShowHelp-import Matterhorn.Events.UrlSelect-import Matterhorn.Events.UserListOverlay-import Matterhorn.Events.ChannelListOverlay-import Matterhorn.Events.ReactionEmojiListOverlay+import Matterhorn.Events.UserListWindow+import Matterhorn.Events.ChannelListWindow+import Matterhorn.Events.ReactionEmojiListWindow import Matterhorn.Events.TabbedWindow-import Matterhorn.Events.ManageAttachments import Matterhorn.Events.Mouse import Matterhorn.Events.EditNotifyPrefs import Matterhorn.Events.Websocket@@ -64,18 +61,16 @@ onBrickEvent (VtyEvent e) = do csLastMouseDownEvent .= Nothing onVtyEvent e-onBrickEvent e@(MouseDown n button modifier _) = do- mhLog LogGeneral $ T.pack $ "MOUSE EVENT: " <> show (n, button, modifier)+onBrickEvent e@(MouseDown n _ _ _) = do lastClick <- use csLastMouseDownEvent let shouldHandle = case lastClick of Nothing -> True Just (MouseDown prevN _ _ _) -> not $ prevN `semeq` n _ -> False when shouldHandle $ do- mhLog LogGeneral "Handling mouse event" csLastMouseDownEvent .= Just e withCurrentTeam $ \tId -> do- mode <- use (csTeam(tId).tsMode)+ mode <- getTeamMode tId mouseHandlerByMode tId mode e onBrickEvent (MouseUp {}) = do csLastMouseDownEvent .= Nothing@@ -192,53 +187,60 @@ "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" onVtyEvent :: Vty.Event -> MH ()-onVtyEvent e = do- case e of- (Vty.EvResize _ _) -> do- -- On resize, invalidate the entire rendering cache since- -- many things depend on the window size.- --- -- Note: we fall through after this because it is sometimes- -- important for modes to have their own additional logic- -- to run when a resize occurs, so we don't want to stop- -- processing here.- mh invalidateCache- withCurrentTeam $ \tId ->- mh $ makeVisible $ SelectedChannelListEntry tId- _ -> return ()+onVtyEvent =+ void .+ handleEventWith [ handleResizeEvent+ , handleKeyboardEvent globalKeybindings+ , handleTeamModeEvent+ ] - void $ handleKeyboardEvent globalKeybindings handleTeamModeEvent e+handleResizeEvent :: Vty.Event -> MH Bool+handleResizeEvent (Vty.EvResize _ _) = do+ -- On resize, invalidate the entire rendering cache since many+ -- things depend on the window size.+ --+ -- Note: we fall through after this because it is sometimes+ -- important for modes to have their own additional logic to run+ -- when a resize occurs, so we don't want to stop processing here.+ mh invalidateCache+ withCurrentTeam $ \tId ->+ mh $ makeVisible $ SelectedChannelListEntry tId -handleTeamModeEvent :: Vty.Event -> MH ()-handleTeamModeEvent e =+ return True+handleResizeEvent _ =+ return False++handleTeamModeEvent :: Vty.Event -> MH Bool+handleTeamModeEvent e = do withCurrentTeam $ \tId -> do- mode <- use (csTeam(tId).tsMode)+ mode <- getTeamMode tId teamEventHandlerByMode tId mode e+ return True teamEventHandlerByMode :: MM.TeamId -> Mode -> Vty.Event -> MH ()-teamEventHandlerByMode tId mode =+teamEventHandlerByMode tId mode e = case mode of- Main -> onEventMain tId- ShowHelp _ _ -> void . onEventShowHelp tId- ChannelSelect -> void . onEventChannelSelect tId- UrlSelect -> void . onEventUrlSelect tId- LeaveChannelConfirm -> onEventLeaveChannelConfirm tId- MessageSelect -> onEventMessageSelect tId- MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm tId- DeleteChannelConfirm -> onEventDeleteChannelConfirm tId- ThemeListOverlay -> onEventThemeListOverlay tId- PostListOverlay _ -> onEventPostListOverlay tId- UserListOverlay -> onEventUserListOverlay tId- ChannelListOverlay -> onEventChannelListOverlay tId- ReactionEmojiListOverlay -> onEventReactionEmojiListOverlay tId- ViewMessage -> void . (handleTabbedWindowEvent+ Main -> onEventMain tId e+ ShowHelp _ -> void $ onEventShowHelp tId e+ ChannelSelect -> void $ onEventChannelSelect tId e+ LeaveChannelConfirm -> onEventLeaveChannelConfirm tId e+ MessageSelectDeleteConfirm target ->+ case target of+ MITeamThread tmId ->+ onEventMessageSelectDeleteConfirm tId (unsafeThreadInterface(tmId)) e+ MIChannel cId ->+ onEventMessageSelectDeleteConfirm tId (csChannelMessageInterface(cId)) e+ DeleteChannelConfirm -> onEventDeleteChannelConfirm tId e+ ThemeListWindow -> onEventThemeListWindow tId e+ PostListWindow _ -> onEventPostListWindow tId e+ UserListWindow -> onEventUserListWindow tId e+ ChannelListWindow -> onEventChannelListWindow tId e+ ReactionEmojiListWindow -> onEventReactionEmojiListWindow tId e+ ViewMessage -> void $ (handleTabbedWindowEvent (csTeam(tId).tsViewedMessage.singular _Just._2)- tId)- ManageAttachments -> onEventManageAttachments tId- ManageAttachmentsBrowseFiles -> onEventManageAttachments tId- EditNotifyPrefs -> void . onEventEditNotifyPrefs tId- ChannelTopicWindow -> onEventChannelTopicWindow tId- SaveAttachmentWindow _ -> onEventSaveAttachmentWindow tId+ tId e)+ EditNotifyPrefs -> void $ onEventEditNotifyPrefs tId e+ ChannelTopicWindow -> onEventChannelTopicWindow tId e -- | Refresh client-accessible server configuration information. This -- is usually triggered when a reconnect event for the WebSocket to the
− src/Matterhorn/Events/ChannelListOverlay.hs
@@ -1,37 +0,0 @@-module Matterhorn.Events.ChannelListOverlay- ( onEventChannelListOverlay- , channelListOverlayKeybindings- , channelListOverlayKeyHandlers- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Graphics.Vty as Vty--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Events.Keybindings-import Matterhorn.State.ChannelListOverlay-import Matterhorn.State.ListOverlay-import Matterhorn.Types---onEventChannelListOverlay :: TeamId -> Vty.Event -> MH ()-onEventChannelListOverlay tId =- void . onEventListOverlay tId (csTeam(tId).tsChannelListOverlay) (channelListOverlayKeybindings tId)---- | The keybindings we want to use while viewing a channel list overlay-channelListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-channelListOverlayKeybindings tId = mkKeybindings (channelListOverlayKeyHandlers tId)--channelListOverlayKeyHandlers :: TeamId -> [KeyEventHandler]-channelListOverlayKeyHandlers tId =- [ mkKb CancelEvent "Close the channel search list" (exitListOverlay tId (csTeam(tId).tsChannelListOverlay))- , mkKb SearchSelectUpEvent "Select the previous channel" $ channelListSelectUp tId- , mkKb SearchSelectDownEvent "Select the next channel" $ channelListSelectDown tId- , mkKb PageDownEvent "Page down in the channel list" $ channelListPageDown tId- , mkKb PageUpEvent "Page up in the channel list" $ channelListPageUp tId- , mkKb ActivateListItemEvent "Join the selected channel" (listOverlayActivateCurrent tId (csTeam(tId).tsChannelListOverlay))- ]
+ src/Matterhorn/Events/ChannelListWindow.hs view
@@ -0,0 +1,37 @@+module Matterhorn.Events.ChannelListWindow+ ( onEventChannelListWindow+ , channelListWindowKeybindings+ , channelListWindowKeyHandlers+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Events.Keybindings+import Matterhorn.State.ChannelListWindow+import Matterhorn.State.ListWindow+import Matterhorn.Types+++onEventChannelListWindow :: TeamId -> Vty.Event -> MH ()+onEventChannelListWindow tId =+ void . onEventListWindow (csTeam(tId).tsChannelListWindow) (channelListWindowKeybindings tId)++-- | The keybindings we want to use while viewing a channel list window+channelListWindowKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap+channelListWindowKeybindings tId = mkKeybindings (channelListWindowKeyHandlers tId)++channelListWindowKeyHandlers :: TeamId -> [KeyEventHandler]+channelListWindowKeyHandlers tId =+ [ mkKb CancelEvent "Close the channel search list" (exitListWindow tId (csTeam(tId).tsChannelListWindow))+ , mkKb SearchSelectUpEvent "Select the previous channel" $ channelListSelectUp tId+ , mkKb SearchSelectDownEvent "Select the next channel" $ channelListSelectDown tId+ , mkKb PageDownEvent "Page down in the channel list" $ channelListPageDown tId+ , mkKb PageUpEvent "Page up in the channel list" $ channelListPageUp tId+ , mkKb ActivateListItemEvent "Join the selected channel" (listWindowActivateCurrent tId (csTeam(tId).tsChannelListWindow))+ ]
src/Matterhorn/Events/ChannelSelect.hs view
@@ -16,14 +16,19 @@ import qualified Matterhorn.Zipper as Z -onEventChannelSelect :: TeamId -> Vty.Event -> MH Bool+onEventChannelSelect :: TeamId -> Vty.Event -> MH () onEventChannelSelect tId =- handleKeyboardEvent (channelSelectKeybindings tId) $ \e -> do- handled <- handleKeyboardEvent (editingKeybindings tId (csTeam(tId).tsChannelSelectState.channelSelectInput)) (const $ return ()) e- when (not handled) $- mhHandleEventLensed (csTeam(tId).tsChannelSelectState.channelSelectInput) handleEditorEvent e-- updateChannelSelectMatches tId+ void .+ handleEventWith [ handleKeyboardEvent (channelSelectKeybindings tId)+ , \e -> do+ void $ handleEventWith [ handleKeyboardEvent (editingKeybindings (csTeam(tId).tsChannelSelectState.channelSelectInput))+ , \ev -> do+ mhHandleEventLensed (csTeam(tId).tsChannelSelectState.channelSelectInput) handleEditorEvent ev+ return True+ ] e+ updateChannelSelectMatches tId+ return True+ ] channelSelectKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap channelSelectKeybindings tId = mkKeybindings (channelSelectKeyHandlers tId)@@ -36,10 +41,10 @@ case Z.focus matches of Nothing -> return () Just match -> do- setMode tId Main+ popMode tId setFocus tId $ channelListEntryChannelId $ matchEntry match - , mkKb CancelEvent "Cancel channel selection" $ setMode tId Main+ , mkKb CancelEvent "Cancel channel selection" $ popMode tId , mkKb NextChannelEvent "Select next match" $ channelSelectNext tId , mkKb PrevChannelEvent "Select previous match" $ channelSelectPrevious tId , mkKb NextChannelEventAlternate "Select next match (alternate binding)" $ channelSelectNext tId
src/Matterhorn/Events/ChannelTopicWindow.hs view
@@ -30,16 +30,16 @@ ed <- use (csTeam(tId).tsChannelTopicDialog.channelTopicDialogEditor) let topic = T.unlines $ getEditContents ed setChannelTopic tId topic- setMode tId Main+ popMode tId Just (ChannelTopicEditor {}) -> mhHandleEventLensed (csTeam(tId).tsChannelTopicDialog.channelTopicDialogEditor) handleEditorEvent e Just (ChannelTopicCancelButton {}) ->- setMode tId Main+ popMode tId _ ->- setMode tId Main+ popMode tId onEventChannelTopicWindow tId (Vty.EvKey Vty.KEsc []) = do- setMode tId Main+ popMode tId onEventChannelTopicWindow tId e = do f <- use (csTeam(tId).tsChannelTopicDialog.channelTopicDialogFocus) case focusGetCurrent f of
src/Matterhorn/Events/DeleteChannelConfirm.hs view
@@ -17,6 +17,8 @@ Vty.KChar c | c `elem` ("yY"::String) -> deleteCurrentChannel tId _ -> return ()- setMode tId Main+ popMode tId+onEventDeleteChannelConfirm _ (Vty.EvResize {}) = do+ return () onEventDeleteChannelConfirm tId _ = do- setMode tId Main+ popMode tId
src/Matterhorn/Events/EditNotifyPrefs.hs view
@@ -26,13 +26,16 @@ onEventEditNotifyPrefs :: TeamId -> V.Event -> MH Bool onEventEditNotifyPrefs tId =- handleKeyboardEvent (editNotifyPrefsKeybindings tId) (handleEditNotifyPrefsEvent tId . VtyEvent)+ handleEventWith [ handleKeyboardEvent (editNotifyPrefsKeybindings tId)+ , handleEditNotifyPrefsEvent tId . VtyEvent+ ] -handleEditNotifyPrefsEvent :: TeamId -> BrickEvent Name MHEvent -> MH ()+handleEditNotifyPrefsEvent :: TeamId -> BrickEvent Name MHEvent -> MH Bool handleEditNotifyPrefsEvent tId e = do form <- use (csTeam(tId).tsNotifyPrefs.singular _Just) updatedForm <- mh $ handleFormEvent e form csTeam(tId).tsNotifyPrefs .= Just updatedForm+ return True editNotifyPrefsKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap editNotifyPrefsKeybindings tId = mkKeybindings (editNotifyPrefsKeyHandlers tId)
src/Matterhorn/Events/Keybindings.hs view
@@ -80,24 +80,21 @@ lookupKeybinding e (KeyHandlerMap m) = M.lookup e m -- | Handle a keyboard event by looking it up in a map of bindings and--- invoking the matching binding's handler. If no match can be found,--- invoke a fallback action instead. Return True if the key event was--- handled with a matching binding; False if not (the fallback case).+-- invoking the matching binding's handler. Return True if the key event+-- was handled with a matching binding; False if not (the fallback+-- case). handleKeyboardEvent :: (KeyConfig -> KeyHandlerMap) -- ^ The function to build a key handler map from a -- key configuration.- -> (Vty.Event -> MH ())- -- ^ The fallback action to invoke if no matching- -- binding can be found. -> Vty.Event -- ^ The event to handle. -> MH Bool-handleKeyboardEvent mkKeyMap fallthrough e = do+handleKeyboardEvent mkKeyMap e = do conf <- use (csResources.crConfiguration) let keyMap = mkKeyMap (configUserKeys conf) case lookupKeybinding e keyMap of Just kh -> (ehAction $ kehHandler $ khHandler kh) >> return True- Nothing -> fallthrough e >> return False+ Nothing -> return False mkHandler :: Text -> MH () -> EventHandler mkHandler msg action =@@ -178,6 +175,7 @@ PrevChannelEventAlternate -> [ kb Vty.KUp ] NextUnreadChannelEvent -> [ meta (key 'a') ] ShowAttachmentListEvent -> [ ctrl (key 'x') ]+ ChangeMessageEditorFocus -> [ meta (key 'o') ] NextUnreadUserOrChannelEvent -> [ ] LastChannelEvent -> [ meta (key 's') ] EnterOpenURLModeEvent -> [ ctrl (key 'o') ]@@ -201,8 +199,8 @@ PageDownEvent -> [ kb Vty.KPageDown ] PageLeftEvent -> [ shift (kb Vty.KLeft) ] PageRightEvent -> [ shift (kb Vty.KRight) ]- ScrollTopEvent -> [ kb Vty.KHome ]- ScrollBottomEvent -> [ kb Vty.KEnd ]+ ScrollTopEvent -> [ kb Vty.KHome, meta $ key '<' ]+ ScrollBottomEvent -> [ kb Vty.KEnd, meta $ key '>' ] SelectOldestMessageEvent -> [ shift (kb Vty.KHome) ] SelectUpEvent -> [ key 'k', kb Vty.KUp ] SelectDownEvent -> [ key 'j', kb Vty.KDown ]@@ -213,6 +211,7 @@ FillGapEvent -> [ kb Vty.KEnter ] CopyPostLinkEvent -> [ key 'l' ] FlagMessageEvent -> [ key 'f' ]+ OpenThreadEvent -> [ key 't' ] PinMessageEvent -> [ key 'p' ] YankMessageEvent -> [ key 'y' ] YankWholeMessageEvent -> [ key 'Y' ]@@ -247,8 +246,8 @@ FileBrowserListPageDownEvent -> [ ctrl (key 'f'), kb Vty.KPageDown ] FileBrowserListHalfPageUpEvent -> [ ctrl (key 'u') ] FileBrowserListHalfPageDownEvent -> [ ctrl (key 'd') ]- FileBrowserListTopEvent -> [ key 'g', kb Vty.KHome ]- FileBrowserListBottomEvent -> [ key 'G', kb Vty.KEnd ]+ FileBrowserListTopEvent -> [ key 'g', kb Vty.KHome, meta $ key '<' ]+ FileBrowserListBottomEvent -> [ key 'G', kb Vty.KEnd, meta $ key '>' ] FileBrowserListNextEvent -> [ key 'j', ctrl (key 'n'), kb Vty.KDown ] FileBrowserListPrevEvent -> [ key 'k', ctrl (key 'p'), kb Vty.KUp ] FormSubmitEvent -> [ kb Vty.KEnter ]
src/Matterhorn/Events/LeaveChannelConfirm.hs view
@@ -17,5 +17,5 @@ Vty.KChar c | c `elem` ("yY"::String) -> leaveCurrentChannel tId _ -> return ()- setMode tId Main+ popMode tId onEventLeaveChannelConfirm _ _ = return ()
src/Matterhorn/Events/Main.hs view
@@ -1,36 +1,41 @@ {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-} module Matterhorn.Events.Main where import Prelude () import Matterhorn.Prelude import Brick.Main ( viewportScroll, vScrollBy )-import Brick.Widgets.Edit import qualified Graphics.Vty as Vty import Network.Mattermost.Types ( TeamId ) import Matterhorn.HelpTopics import Matterhorn.Events.Keybindings-import Matterhorn.State.Attachments+import Matterhorn.Events.MessageInterface+import Matterhorn.Events.ThreadWindow import Matterhorn.State.ChannelSelect import Matterhorn.State.Channels import Matterhorn.State.Editing import Matterhorn.State.Help-import Matterhorn.State.MessageSelect-import Matterhorn.State.PostListOverlay ( enterFlaggedPostListMode )-import Matterhorn.State.UrlSelect+import Matterhorn.State.Teams+import Matterhorn.State.PostListWindow ( enterFlaggedPostListMode ) import Matterhorn.Types - onEventMain :: TeamId -> Vty.Event -> MH () onEventMain tId =- void . handleKeyboardEvent (mainKeybindings tId) (\ ev -> do- resetReturnChannel tId- case ev of- (Vty.EvPaste bytes) -> handlePaste tId bytes- _ -> handleEditingInput tId ev- )+ void .+ handleEventWith [ handleKeyboardEvent (mainKeybindings tId)+ , \e -> do+ st <- use id+ case st^.csTeam(tId).tsMessageInterfaceFocus of+ FocusThread -> onEventThreadWindow tId e+ FocusCurrentChannel -> do+ mCid <- use (csCurrentChannelId(tId))+ case mCid of+ Nothing -> return False+ Just cId -> handleMessageInterfaceEvent tId (csChannelMessageInterface(cId)) e+ ] mainKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap mainKeybindings tId = mkKeybindings (mainKeyHandlers tId)@@ -41,42 +46,21 @@ "Show this help screen" $ do showHelpScreen tId mainHelpTopic - , mkKb EnterSelectModeEvent- "Select a message to edit/reply/delete" $- beginMessageSelect tId-- , mkKb ReplyRecentEvent- "Reply to the most recent message" $- replyToLatestMessage tId- , mkKb- InvokeEditorEvent- "Invoke `$EDITOR` to edit the current message" $- invokeExternalEditor tId-- , mkKb EnterFastSelectModeEvent "Enter fast channel selection mode" $ beginChannelSelect tId - , staticKb "Tab-complete forward"- (Vty.EvKey (Vty.KChar '\t') []) $- tabComplete tId Forwards-- , staticKb "Tab-complete backward"- (Vty.EvKey (Vty.KBackTab) []) $- tabComplete tId Backwards- , mkKb ChannelListScrollUpEvent "Scroll up in the channel list" $ do- let vp = viewportScroll $ ChannelList tId+ let vp = viewportScroll $ ChannelListViewport tId mh $ vScrollBy vp (-1) , mkKb ChannelListScrollDownEvent "Scroll down in the channel list" $ do- let vp = viewportScroll $ ChannelList tId+ let vp = viewportScroll $ ChannelListViewport tId mh $ vScrollBy vp 1 , mkKb@@ -84,34 +68,14 @@ "Cycle through channel list sorting modes" $ cycleChannelListSortingMode tId - , mkKb- ScrollUpEvent- "Scroll up in the channel input history" $ do- -- Up in multiline mode does the usual thing; otherwise we- -- navigate the history.- isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline)- case isMultiline of- True -> mhHandleEventLensed (csTeam(tId).tsEditState.cedEditor) handleEditorEvent- (Vty.EvKey Vty.KUp [])- False -> channelHistoryBackward tId-- , mkKb- ScrollDownEvent- "Scroll down in the channel input history" $ do- -- Down in multiline mode does the usual thing; otherwise- -- we navigate the history.- isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline)- case isMultiline of- True -> mhHandleEventLensed (csTeam(tId).tsEditState.cedEditor) handleEditorEvent- (Vty.EvKey Vty.KDown [])- False -> channelHistoryForward tId-- , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do- beginMessageSelect tId+ , mkKb ReplyRecentEvent+ "Reply to the most recent message" $+ withCurrentChannel tId $ \cId _ ->+ replyToLatestMessage (channelEditor(cId)) - , mkKb SelectOldestMessageEvent "Scroll to top of channel message list" $ do- beginMessageSelect tId- messageSelectFirst tId+ , mkKb ChangeMessageEditorFocus+ "Cycle between message editors when a thread is open" $+ cycleTeamMessageInterfaceFocus tId , mkKb NextChannelEvent "Change to the next channel in the channel list" $ nextChannel tId@@ -122,9 +86,6 @@ , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages or return to the channel marked '~'" $ nextUnreadChannel tId - , mkKb ShowAttachmentListEvent "Show the attachment list" $- showAttachmentList tId- , mkKb NextUnreadUserOrChannelEvent "Change to the next channel with unread messages preferring direct messages" $ nextUnreadUserOrChannel tId@@ -132,31 +93,9 @@ , mkKb LastChannelEvent "Change to the most recently-focused channel" $ recentChannel tId - , staticKb "Send the current message"- (Vty.EvKey Vty.KEnter []) $ do- isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline)- case isMultiline of- -- Normally, this event causes the current message to- -- be sent. But in multiline mode we want to insert a- -- newline instead.- True -> handleEditingInput tId (Vty.EvKey Vty.KEnter [])- False -> do- withCurrentChannel tId $ \cId _ -> do- content <- getEditorContent tId- handleInputSubmission tId cId content-- , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" $- startUrlSelect tId- , mkKb ClearUnreadEvent "Clear the current channel's unread / edited indicators" $ do withCurrentChannel tId $ \cId _ -> do clearChannelUnreadStatus cId-- , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode" $- toggleMultilineEditing tId-- , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order" $- cancelAutocompleteOrReplyOrEdit tId , mkKb EnterFlaggedPostsEvent "View currently flagged posts" $ enterFlaggedPostListMode tId
src/Matterhorn/Events/ManageAttachments.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-} module Matterhorn.Events.ManageAttachments- ( onEventManageAttachments+ ( onEventAttachmentList+ , onEventBrowseFile , attachmentListKeybindings , attachmentBrowseKeyHandlers , attachmentBrowseKeybindings@@ -17,9 +19,7 @@ import qualified Data.Text as T import qualified Data.Vector as Vector import qualified Graphics.Vty as V-import Lens.Micro.Platform ( (?=), (%=), to )--import Network.Mattermost.Types ( TeamId )+import Lens.Micro.Platform ( (?=), (%=), to, Lens', (.=) ) import Matterhorn.Types import Matterhorn.Types.KeyEvents@@ -28,86 +28,90 @@ import Matterhorn.State.Common -onEventManageAttachments :: TeamId -> V.Event -> MH ()-onEventManageAttachments tId e = do- mode <- use (csTeam(tId).tsMode)- case mode of- ManageAttachments -> void $ onEventAttachmentList tId e- ManageAttachmentsBrowseFiles -> onEventBrowseFile tId e- _ -> error "BUG: onEventManageAttachments called in invalid mode"--onEventAttachmentList :: TeamId -> V.Event -> MH Bool-onEventAttachmentList tId =- handleKeyboardEvent (attachmentListKeybindings tId) $- mhHandleEventLensed (csTeam(tId).tsEditState.cedAttachmentList) L.handleListEvent+onEventAttachmentList :: Lens' ChatState (MessageInterface Name i)+ -> V.Event+ -> MH Bool+onEventAttachmentList which =+ handleEventWith [ handleKeyboardEvent (attachmentListKeybindings which)+ , \e -> mhHandleEventLensed (which.miEditor.esAttachmentList) L.handleListEvent e >> return True+ ] -attachmentListKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-attachmentListKeybindings tId = mkKeybindings (attachmentListKeyHandlers tId)+attachmentListKeybindings :: Lens' ChatState (MessageInterface Name i)+ -> KeyConfig+ -> KeyHandlerMap+attachmentListKeybindings which = mkKeybindings (attachmentListKeyHandlers which) -attachmentListKeyHandlers :: TeamId -> [KeyEventHandler]-attachmentListKeyHandlers tId =+attachmentListKeyHandlers :: Lens' ChatState (MessageInterface Name i)+ -> [KeyEventHandler]+attachmentListKeyHandlers which = [ mkKb CancelEvent "Close attachment list" $- setMode tId Main+ which.miMode .= Compose , mkKb SelectUpEvent "Move cursor up" $- mhHandleEventLensed (csTeam(tId).tsEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KUp [])+ mhHandleEventLensed (which.miEditor.esAttachmentList) L.handleListEvent (V.EvKey V.KUp []) , mkKb SelectDownEvent "Move cursor down" $- mhHandleEventLensed (csTeam(tId).tsEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KDown [])+ mhHandleEventLensed (which.miEditor.esAttachmentList) L.handleListEvent (V.EvKey V.KDown []) , mkKb AttachmentListAddEvent "Add a new attachment to the attachment list" $- showAttachmentFileBrowser tId+ showAttachmentFileBrowser which , mkKb AttachmentOpenEvent "Open the selected attachment using the URL open command" $- openSelectedAttachment tId+ openSelectedAttachment which , mkKb AttachmentListDeleteEvent "Delete the selected attachment from the attachment list" $- deleteSelectedAttachment tId+ deleteSelectedAttachment which ] -attachmentBrowseKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-attachmentBrowseKeybindings tId = mkKeybindings (attachmentBrowseKeyHandlers tId)+attachmentBrowseKeybindings :: Lens' ChatState (MessageInterface Name i)+ -> KeyConfig+ -> KeyHandlerMap+attachmentBrowseKeybindings which =+ mkKeybindings (attachmentBrowseKeyHandlers which) -attachmentBrowseKeyHandlers :: TeamId -> [KeyEventHandler]-attachmentBrowseKeyHandlers tId =+attachmentBrowseKeyHandlers :: Lens' ChatState (MessageInterface Name i)+ -> [KeyEventHandler]+attachmentBrowseKeyHandlers which = [ mkKb CancelEvent "Cancel attachment file browse" $- cancelAttachmentBrowse tId+ cancelAttachmentBrowse which , mkKb AttachmentOpenEvent "Open the selected file using the URL open command" $- openSelectedBrowserEntry tId+ openSelectedBrowserEntry which , mkKb FileBrowserBeginSearchEvent "Begin search for name in list" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserBeginSearch , mkKb FileBrowserSelectEnterEvent "Select file or enter directory" $ do- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserSelectEnter- withFileBrowser tId (tryAddAttachment tId . FB.fileBrowserSelection)+ withFileBrowser which (tryAddAttachment which . FB.fileBrowserSelection) , mkKb FileBrowserSelectCurrentEvent "Select file" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserSelectCurrent , mkKb FileBrowserListPageUpEvent "Move cursor one page up" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListPageUp , mkKb FileBrowserListPageDownEvent "Move cursor one page down" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListPageDown , mkKb FileBrowserListHalfPageUpEvent "Move cursor one-half page up" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListHalfPageUp , mkKb FileBrowserListHalfPageDownEvent "Move cursor one-half page down" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListHalfPageDown , mkKb FileBrowserListTopEvent "Move cursor to top of list" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListTop , mkKb FileBrowserListBottomEvent "Move cursor to bottom of list" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListBottom , mkKb FileBrowserListNextEvent "Move cursor down" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListNext , mkKb FileBrowserListPrevEvent "Move cursor up" $- mhHandleEventLensed' (csTeam(tId).tsEditState.unsafeCedFileBrowser)+ mhHandleEventLensed' (which.miEditor.unsafeEsFileBrowser) FB.actionFileBrowserListPrev ] -withFileBrowser :: TeamId -> ((FB.FileBrowser Name) -> MH ()) -> MH ()-withFileBrowser tId f = do- use (csTeam(tId).tsEditState.cedFileBrowser) >>= \case+withFileBrowser :: Lens' ChatState (MessageInterface Name i)+ -> ((FB.FileBrowser Name) -> MH ())+ -> MH ()+withFileBrowser which f = do+ use (which.miEditor.esFileBrowser) >>= \case Nothing -> do -- The widget has not been created yet. This should -- normally not occur, because the ManageAttachments@@ -116,65 +120,70 @@ -- This could therefore be implemented as an `error "BUG: -- ..."` handler, but the more benign approach is to -- simply create an available FileBrowser at this stage.- new_b <- liftIO $ FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser tId) Nothing- csTeam(tId).tsEditState.cedFileBrowser ?= new_b+ cId <- use (which.miEditor.esChannelId)+ new_b <- liftIO $ FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser cId) Nothing+ which.miEditor.esFileBrowser ?= new_b f new_b Just b -> f b -openSelectedAttachment :: TeamId -> MH ()-openSelectedAttachment tId = do- cur <- use (csTeam(tId).tsEditState.cedAttachmentList.to L.listSelectedElement)+openSelectedAttachment :: Lens' ChatState (MessageInterface Name i) -> MH ()+openSelectedAttachment which = do+ cur <- use (which.miEditor.esAttachmentList.to L.listSelectedElement) case cur of Nothing -> return () Just (_, entry) -> void $ openFilePath (FB.fileInfoFilePath $ attachmentDataFileInfo entry) -openSelectedBrowserEntry :: TeamId -> MH ()-openSelectedBrowserEntry tId = withFileBrowser tId $ \b ->+openSelectedBrowserEntry :: Lens' ChatState (MessageInterface Name i) -> MH ()+openSelectedBrowserEntry which = withFileBrowser which $ \b -> case FB.fileBrowserCursor b of Nothing -> return () Just entry -> void $ openFilePath (FB.fileInfoFilePath entry) -onEventBrowseFile :: TeamId -> V.Event -> MH ()-onEventBrowseFile tId e = do- withFileBrowser tId $ \b -> do+onEventBrowseFile :: Lens' ChatState (MessageInterface Name i) -> V.Event -> MH Bool+onEventBrowseFile which e = do+ withFileBrowser which $ \b -> do case FB.fileBrowserIsSearching b of False ->- void $ handleKeyboardEvent (attachmentBrowseKeybindings tId) (handleFileBrowserEvent tId) e+ void $ handleEventWith [ handleKeyboardEvent (attachmentBrowseKeybindings which)+ , \_ -> handleFileBrowserEvent which e >> return True+ ] e True ->- handleFileBrowserEvent tId e+ handleFileBrowserEvent which e -- n.b. the FileBrowser may have been updated above, so re-acquire it- withFileBrowser tId $ \b -> do+ withFileBrowser which $ \b -> do case FB.fileBrowserException b of Nothing -> return () Just ex -> do mhLog LogError $ T.pack $ "FileBrowser exception: " <> show ex -cancelAttachmentBrowse :: TeamId -> MH ()-cancelAttachmentBrowse tId = do- es <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL)- case length es of- 0 -> setMode tId Main- _ -> setMode tId ManageAttachments+ return True -handleFileBrowserEvent :: TeamId -> V.Event -> MH ()-handleFileBrowserEvent tId e = do+cancelAttachmentBrowse :: Lens' ChatState (MessageInterface Name i) -> MH ()+cancelAttachmentBrowse which = do+ es <- use (which.miEditor.esAttachmentList.L.listElementsL)+ which.miMode .= case length es of+ 0 -> Compose+ _ -> ManageAttachments++handleFileBrowserEvent :: Lens' ChatState (MessageInterface Name i) -> V.Event -> MH ()+handleFileBrowserEvent which e = do let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev))- mhHandleEventLensed (csTeam(tId).tsEditState.cedFileBrowser) fbHandle e+ mhHandleEventLensed (which.miEditor.esFileBrowser) fbHandle e -- TODO: Check file browser exception state- withFileBrowser tId $ \b ->- tryAddAttachment tId $ FB.fileBrowserSelection b+ withFileBrowser which $ \b ->+ tryAddAttachment which (FB.fileBrowserSelection b) -deleteSelectedAttachment :: TeamId -> MH ()-deleteSelectedAttachment tId = do- es <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL)- mSel <- use (csTeam(tId).tsEditState.cedAttachmentList.to L.listSelectedElement)+deleteSelectedAttachment :: Lens' ChatState (MessageInterface Name i) -> MH ()+deleteSelectedAttachment which = do+ es <- use (which.miEditor.esAttachmentList.L.listElementsL)+ mSel <- use (which.miEditor.esAttachmentList.to L.listSelectedElement) case mSel of Nothing -> return () Just (pos, _) -> do- oldIdx <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listSelectedL)+ oldIdx <- use (which.miEditor.esAttachmentList.L.listSelectedL) let idx = if Vector.length es == 1 then Nothing else case oldIdx of@@ -182,7 +191,7 @@ Just old -> if pos >= old then Just $ pos - 1 else Just pos- csTeam(tId).tsEditState.cedAttachmentList %= L.listReplace (deleteAt pos es) idx+ which.miEditor.esAttachmentList %= L.listReplace (deleteAt pos es) idx deleteAt :: Int -> Vector.Vector a -> Vector.Vector a deleteAt p as | p < 0 || p >= length as = as
+ src/Matterhorn/Events/MessageInterface.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE RankNTypes #-}+module Matterhorn.Events.MessageInterface+ ( handleMessageInterfaceEvent+ , messageInterfaceKeyHandlers+ , extraEditorKeyHandlers+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick.Widgets.Edit ( handleEditorEvent )++import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( Lens' )+import Network.Mattermost.Types ( TeamId )++import Matterhorn.Types+import Matterhorn.Types.KeyEvents+import Matterhorn.Events.SaveAttachmentWindow+import Matterhorn.Events.ManageAttachments+import Matterhorn.Events.MessageSelect+import Matterhorn.Events.Keybindings+import Matterhorn.Events.UrlSelect+import Matterhorn.State.Attachments+import Matterhorn.State.Editing+import Matterhorn.State.UrlSelect+import Matterhorn.State.MessageSelect+import Matterhorn.State.Channels+++handleMessageInterfaceEvent :: TeamId+ -> Lens' ChatState (MessageInterface Name i)+ -> Vty.Event+ -> MH Bool+handleMessageInterfaceEvent tId which ev = do+ mode <- use (which.miMode)+ case mode of+ Compose ->+ handleEventWith [ handleKeyboardEvent (extraEditorKeybindings which)+ , handleKeyboardEvent (messageInterfaceKeybindings which)+ , \e -> do+ case e of+ (Vty.EvPaste bytes) -> handlePaste (which.miEditor) bytes+ _ -> handleEditingInput (which.miEditor) e+ return True+ ] ev+ MessageSelect ->+ onEventMessageSelect tId which ev+ ShowUrlList ->+ onEventUrlSelect which ev+ SaveAttachment {} ->+ onEventSaveAttachmentWindow which ev+ ManageAttachments ->+ onEventAttachmentList which ev+ BrowseFiles ->+ onEventBrowseFile which ev++messageInterfaceKeybindings :: Lens' ChatState (MessageInterface n i)+ -> KeyConfig+ -> KeyHandlerMap+messageInterfaceKeybindings which =+ mkKeybindings (messageInterfaceKeyHandlers which)++messageInterfaceKeyHandlers :: Lens' ChatState (MessageInterface n i)+ -> [KeyEventHandler]+messageInterfaceKeyHandlers which =+ [ mkKb EnterSelectModeEvent+ "Select a message to edit/reply/delete" $+ beginMessageSelect which++ , mkKb PageUpEvent "Page up in the message list (enters message select mode)" $ do+ beginMessageSelect which++ , mkKb SelectOldestMessageEvent "Scroll to top of message list" $ do+ beginMessageSelect which+ messageSelectFirst which++ , mkKb EnterOpenURLModeEvent "Select and open a URL from the current message list" $+ startUrlSelect which+ ]++extraEditorKeybindings :: Lens' ChatState (MessageInterface Name i)+ -> KeyConfig+ -> KeyHandlerMap+extraEditorKeybindings which =+ mkKeybindings (extraEditorKeyHandlers which)++extraEditorKeyHandlers :: Lens' ChatState (MessageInterface Name i)+ -> [KeyEventHandler]+extraEditorKeyHandlers which =+ let editWhich :: Lens' ChatState (EditState Name)+ editWhich = which.miEditor+ in [ mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode" $+ toggleMultilineEditing editWhich++ , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order" $+ cancelAutocompleteOrReplyOrEdit editWhich++ , mkKb+ InvokeEditorEvent+ "Invoke `$EDITOR` to edit the current message" $+ invokeExternalEditor editWhich++ , staticKb "Tab-complete forward"+ (Vty.EvKey (Vty.KChar '\t') []) $+ tabComplete editWhich Forwards++ , staticKb "Tab-complete backward"+ (Vty.EvKey (Vty.KBackTab) []) $+ tabComplete editWhich Backwards++ , mkKb ShowAttachmentListEvent "Show the attachment list" $+ showAttachmentList which++ , staticKb "Send the current message"+ (Vty.EvKey Vty.KEnter []) $ do+ isMultiline <- use (editWhich.esEphemeral.eesMultiline)+ case isMultiline of+ -- Normally, this event causes the current message to+ -- be sent. But in multiline mode we want to insert a+ -- newline instead.+ True -> handleEditingInput editWhich (Vty.EvKey Vty.KEnter [])+ False -> do+ content <- getEditorContent editWhich+ handleInputSubmission editWhich content++ , mkKb+ ScrollUpEvent+ "Scroll up in the channel input history" $ do+ -- Up in multiline mode does the usual thing; otherwise we+ -- navigate the history.+ isMultiline <- use (editWhich.esEphemeral.eesMultiline)+ case isMultiline of+ True -> mhHandleEventLensed (editWhich.esEditor) handleEditorEvent+ (Vty.EvKey Vty.KUp [])+ False -> inputHistoryBackward which++ , mkKb+ ScrollDownEvent+ "Scroll down in the channel input history" $ do+ -- Down in multiline mode does the usual thing; otherwise+ -- we navigate the history.+ isMultiline <- use (editWhich.esEphemeral.eesMultiline)+ case isMultiline of+ True -> mhHandleEventLensed (editWhich.esEditor) handleEditorEvent+ (Vty.EvKey Vty.KDown [])+ False -> inputHistoryForward which+ ]+
src/Matterhorn/Events/MessageSelect.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.Events.MessageSelect ( messageSelectKeybindings , messageSelectKeyHandlers@@ -11,85 +12,110 @@ import qualified Data.Text as T import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( Lens', to ) import Network.Mattermost.Types ( TeamId ) import Matterhorn.Events.Keybindings import Matterhorn.State.MessageSelect-import Matterhorn.State.ReactionEmojiListOverlay+import Matterhorn.State.ReactionEmojiListWindow import Matterhorn.Types messagesPerPageOperation :: Int messagesPerPageOperation = 10 -onEventMessageSelect :: TeamId -> Vty.Event -> MH ()-onEventMessageSelect tId =- void . handleKeyboardEvent (messageSelectKeybindings tId) (const $ return ())+onEventMessageSelect :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> Vty.Event+ -> MH Bool+onEventMessageSelect tId which =+ handleKeyboardEvent (messageSelectKeybindings tId which) -onEventMessageSelectDeleteConfirm :: TeamId -> Vty.Event -> MH ()-onEventMessageSelectDeleteConfirm tId (Vty.EvKey (Vty.KChar 'y') []) = do- deleteSelectedMessage tId- setMode tId Main-onEventMessageSelectDeleteConfirm tId _ = do- setMode tId Main+onEventMessageSelectDeleteConfirm :: TeamId -> Lens' ChatState (MessageInterface Name i) -> Vty.Event -> MH ()+onEventMessageSelectDeleteConfirm tId which (Vty.EvKey (Vty.KChar 'y') []) = do+ deleteSelectedMessage which+ popMode tId+onEventMessageSelectDeleteConfirm _ _ (Vty.EvResize {}) = do+ return ()+onEventMessageSelectDeleteConfirm tId _ _ = do+ popMode tId -messageSelectKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-messageSelectKeybindings tId = mkKeybindings (messageSelectKeyHandlers tId)+messageSelectKeybindings :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> KeyConfig+ -> KeyHandlerMap+messageSelectKeybindings tId which =+ mkKeybindings (messageSelectKeyHandlers tId which) -messageSelectKeyHandlers :: TeamId -> [KeyEventHandler]-messageSelectKeyHandlers tId =- [ mkKb CancelEvent "Cancel message selection" $ do- setMode tId Main+messageSelectKeyHandlers :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> [KeyEventHandler]+messageSelectKeyHandlers tId which =+ [ mkKb CancelEvent "Cancel message selection" $+ exitMessageSelect which - , mkKb SelectUpEvent "Select the previous message" $ messageSelectUp tId- , mkKb SelectDownEvent "Select the next message" $ messageSelectDown tId+ , mkKb SelectUpEvent "Select the previous message" $+ messageSelectUp which++ , mkKb SelectDownEvent "Select the next message" $+ messageSelectDown which+ , mkKb ScrollTopEvent "Scroll to top and select the oldest message" $- messageSelectFirst tId+ messageSelectFirst which+ , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message" $- messageSelectLast tId+ messageSelectLast which+ , mkKb PageUpEvent (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages")- (messageSelectUpBy tId messagesPerPageOperation)+ (messageSelectUpBy which messagesPerPageOperation)+ , mkKb PageDownEvent (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages")- (messageSelectDownBy tId messagesPerPageOperation)+ (messageSelectDownBy which messagesPerPageOperation) , mkKb OpenMessageURLEvent "Open all URLs in the selected message" $- openSelectedMessageURLs tId+ openSelectedMessageURLs which , mkKb ReplyMessageEvent "Begin composing a reply to the selected message" $- beginReplyCompose tId+ beginReplyCompose which , mkKb EditMessageEvent "Begin editing the selected message" $- beginEditMessage tId+ beginEditMessage which , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)" $- beginConfirmDeleteSelectedMessage tId+ beginConfirmDeleteSelectedMessage tId which , mkKb YankMessageEvent "Copy a verbatim section or message to the clipboard" $- yankSelectedMessageVerbatim tId+ yankSelectedMessageVerbatim which , mkKb YankWholeMessageEvent "Copy an entire message to the clipboard" $- yankSelectedMessage tId+ yankSelectedMessage which , mkKb PinMessageEvent "Toggle whether the selected message is pinned" $- pinSelectedMessage tId+ pinSelectedMessage which , mkKb FlagMessageEvent "Flag the selected message" $- flagSelectedMessage tId+ flagSelectedMessage which , mkKb ViewMessageEvent "View the selected message" $- viewSelectedMessage tId+ viewSelectedMessage tId which + , mkKb OpenThreadEvent "Open the selected message's thread in a thread window" $ do+ openThreadWindow tId which+ , mkKb FillGapEvent "Fetch messages for the selected gap" $- fillSelectedGap tId+ fillSelectedGap which - , mkKb ReactToMessageEvent "Post a reaction to the selected message" $- enterReactionEmojiListOverlayMode tId+ , mkKb ReactToMessageEvent "Post a reaction to the selected message" $ do+ mMsg <- use (to (getSelectedMessage which))+ case mMsg of+ Nothing -> return ()+ Just m -> enterReactionEmojiListWindowMode tId m , mkKb CopyPostLinkEvent "Copy a post's link to the clipboard" $- copyPostLink tId+ copyPostLink tId which ]
src/Matterhorn/Events/Mouse.hs view
@@ -12,10 +12,11 @@ import Matterhorn.State.Channels import Matterhorn.State.Teams ( setTeam )-import Matterhorn.State.ListOverlay ( listOverlayActivate )+import Matterhorn.State.ListWindow ( listWindowActivate ) import Matterhorn.Types import Matterhorn.Events.EditNotifyPrefs ( handleEditNotifyPrefsEvent )+import Matterhorn.State.MessageSelect ( exitMessageSelect ) import Matterhorn.State.Reactions ( toggleReaction ) import Matterhorn.State.Links ( openLinkTarget ) @@ -26,9 +27,8 @@ mouseHandlerByMode tId mode = case mode of ChannelSelect -> channelSelectMouseHandler tId- EditNotifyPrefs -> handleEditNotifyPrefsEvent tId- ReactionEmojiListOverlay -> reactionEmojiListMouseHandler tId- UrlSelect -> urlListMouseHandler+ EditNotifyPrefs -> void . handleEditNotifyPrefsEvent tId+ ReactionEmojiListWindow -> reactionEmojiListMouseHandler tId _ -> globalMouseHandler tId -- Handle global mouse click events (when mode is not important).@@ -55,34 +55,48 @@ -- it isn't the end of the world. globalMouseHandler :: TeamId -> BrickEvent Name MHEvent -> MH () globalMouseHandler tId (MouseDown n _ _ _) = do+ st <- use id case n of ClickableChannelListEntry channelId -> do whenMode tId Main $ do resetReturnChannel tId setFocus tId channelId- setMode tId Main ClickableTeamListEntry teamId -> -- We deliberately handle this event in all modes; this -- allows us to switch the UI to another team regardless of -- what state it is in, which is by design since all teams -- have their own UI states. setTeam teamId- ClickableURLInMessage _ _ t ->- void $ openLinkTarget t- ClickableURL _ _ t ->+ ClickableURL _ _ _ t -> void $ openLinkTarget t- ClickableUsernameInMessage _ _ username ->- changeChannelByName tId $ addUserSigil username- ClickableUsername _ _ username ->+ ClickableUsername _ _ _ username | username /= myUsername st -> do+ whenMode tId ViewMessage $ do+ -- Pop view message mode+ popMode tId+ -- Exit message select for the focused interface,+ -- since that is the only way we get into message+ -- view mode and we want to reset the focused message+ -- interface mode so that when we return to it from the+ -- DM channel, it's not still stuck in message selection+ -- mode.+ foc <- use (csTeam(tId).tsMessageInterfaceFocus)+ case foc of+ FocusThread ->+ exitMessageSelect $ unsafeThreadInterface tId+ FocusCurrentChannel -> do+ mcId <- use (csCurrentChannelId(tId))+ case mcId of+ Nothing -> return ()+ Just cId -> exitMessageSelect $ csChannelMessageInterface cId changeChannelByName tId $ addUserSigil username- ClickableAttachment fId ->+ ClickableAttachmentInMessage _ fId -> void $ openLinkTarget $ LinkFileId fId- ClickableReactionInMessage pId t uIds ->- void $ toggleReaction pId t uIds- ClickableReaction pId t uIds ->+ ClickableReaction pId _ t uIds -> void $ toggleReaction pId t uIds ClickableChannelListGroupHeading label -> toggleChannelListGroupVisibility label+ ClickableURLListEntry _ t ->+ void $ openLinkTarget t VScrollBar e vpName -> do let vp = viewportScroll vpName mh $ case e of@@ -96,21 +110,15 @@ globalMouseHandler _ _ = return () -urlListMouseHandler :: BrickEvent Name MHEvent -> MH ()-urlListMouseHandler (MouseDown (ClickableURLListEntry _ t) _ _ _) =- void $ openLinkTarget t-urlListMouseHandler _ =- return ()- channelSelectMouseHandler :: TeamId -> BrickEvent Name MHEvent -> MH ()-channelSelectMouseHandler tId (MouseDown (ChannelSelectEntry match) _ _ _) = do- setMode tId Main+channelSelectMouseHandler tId (MouseDown (ClickableChannelSelectEntry match) _ _ _) = do+ popMode tId setFocus tId $ channelListEntryChannelId $ matchEntry match channelSelectMouseHandler _ _ = return () reactionEmojiListMouseHandler :: TeamId -> BrickEvent Name MHEvent -> MH ()-reactionEmojiListMouseHandler tId (MouseDown (ReactionEmojiListOverlayEntry val) _ _ _) =- listOverlayActivate tId (csTeam(tId).tsReactionEmojiListOverlay) val+reactionEmojiListMouseHandler tId (MouseDown (ClickableReactionEmojiListWindowEntry val) _ _ _) =+ listWindowActivate tId (csTeam(tId).tsReactionEmojiListWindow) val reactionEmojiListMouseHandler _ _ = return ()
− src/Matterhorn/Events/PostListOverlay.hs
@@ -1,30 +0,0 @@-module Matterhorn.Events.PostListOverlay where--import Prelude ()-import Matterhorn.Prelude--import qualified Graphics.Vty as Vty--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Types-import Matterhorn.Events.Keybindings-import Matterhorn.State.PostListOverlay---onEventPostListOverlay :: TeamId -> Vty.Event -> MH ()-onEventPostListOverlay tId =- void . handleKeyboardEvent (postListOverlayKeybindings tId) (const $ return ())---- | The keybindings we want to use while viewing a post list overlay-postListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-postListOverlayKeybindings tId = mkKeybindings (postListOverlayKeyHandlers tId)--postListOverlayKeyHandlers :: TeamId -> [KeyEventHandler]-postListOverlayKeyHandlers tId =- [ mkKb CancelEvent "Exit post browsing" $ exitPostListMode tId- , mkKb SelectUpEvent "Select the previous message" $ postListSelectUp tId- , mkKb SelectDownEvent "Select the next message" $ postListSelectDown tId- , mkKb FlagMessageEvent "Toggle the selected message flag" $ postListUnflagSelected tId- , mkKb ActivateListItemEvent "Jump to and select current message" $ postListJumpToCurrent tId- ]
+ src/Matterhorn/Events/PostListWindow.hs view
@@ -0,0 +1,30 @@+module Matterhorn.Events.PostListWindow where++import Prelude ()+import Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Types+import Matterhorn.Events.Keybindings+import Matterhorn.State.PostListWindow+++onEventPostListWindow :: TeamId -> Vty.Event -> MH ()+onEventPostListWindow tId =+ void . handleKeyboardEvent (postListWindowKeybindings tId)++-- | The keybindings we want to use while viewing a post list window+postListWindowKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap+postListWindowKeybindings tId = mkKeybindings (postListWindowKeyHandlers tId)++postListWindowKeyHandlers :: TeamId -> [KeyEventHandler]+postListWindowKeyHandlers tId =+ [ mkKb CancelEvent "Exit post browsing" $ exitPostListMode tId+ , mkKb SelectUpEvent "Select the previous message" $ postListSelectUp tId+ , mkKb SelectDownEvent "Select the next message" $ postListSelectDown tId+ , mkKb FlagMessageEvent "Toggle the selected message flag" $ postListUnflagSelected tId+ , mkKb ActivateListItemEvent "Jump to and select current message" $ postListJumpToCurrent tId+ ]
− src/Matterhorn/Events/ReactionEmojiListOverlay.hs
@@ -1,44 +0,0 @@-module Matterhorn.Events.ReactionEmojiListOverlay- ( onEventReactionEmojiListOverlay- , reactionEmojiListOverlayKeybindings- , reactionEmojiListOverlayKeyHandlers- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Graphics.Vty as Vty--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Events.Keybindings-import Matterhorn.State.ReactionEmojiListOverlay-import Matterhorn.State.ListOverlay-import Matterhorn.Types---onEventReactionEmojiListOverlay :: TeamId -> Vty.Event -> MH ()-onEventReactionEmojiListOverlay tId =- void . onEventListOverlay tId (csTeam(tId).tsReactionEmojiListOverlay)- (reactionEmojiListOverlayKeybindings tId)---- | The keybindings we want to use while viewing an emoji list overlay-reactionEmojiListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-reactionEmojiListOverlayKeybindings tId = mkKeybindings (reactionEmojiListOverlayKeyHandlers tId)--reactionEmojiListOverlayKeyHandlers :: TeamId -> [KeyEventHandler]-reactionEmojiListOverlayKeyHandlers tId =- [ mkKb CancelEvent "Close the emoji search window"- (exitListOverlay tId (csTeam(tId).tsReactionEmojiListOverlay))- , mkKb SearchSelectUpEvent "Select the previous emoji" $- reactionEmojiListSelectUp tId- , mkKb SearchSelectDownEvent "Select the next emoji" $- reactionEmojiListSelectDown tId- , mkKb PageDownEvent "Page down in the emoji list" $- reactionEmojiListPageDown tId- , mkKb PageUpEvent "Page up in the emoji list" $- reactionEmojiListPageUp tId- , mkKb ActivateListItemEvent "Post the selected emoji reaction"- (listOverlayActivateCurrent tId (csTeam(tId).tsReactionEmojiListOverlay))- ]
+ src/Matterhorn/Events/ReactionEmojiListWindow.hs view
@@ -0,0 +1,44 @@+module Matterhorn.Events.ReactionEmojiListWindow+ ( onEventReactionEmojiListWindow+ , reactionEmojiListWindowKeybindings+ , reactionEmojiListWindowKeyHandlers+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Events.Keybindings+import Matterhorn.State.ReactionEmojiListWindow+import Matterhorn.State.ListWindow+import Matterhorn.Types+++onEventReactionEmojiListWindow :: TeamId -> Vty.Event -> MH ()+onEventReactionEmojiListWindow tId =+ void . onEventListWindow (csTeam(tId).tsReactionEmojiListWindow)+ (reactionEmojiListWindowKeybindings tId)++-- | The keybindings we want to use while viewing an emoji list window+reactionEmojiListWindowKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap+reactionEmojiListWindowKeybindings tId = mkKeybindings (reactionEmojiListWindowKeyHandlers tId)++reactionEmojiListWindowKeyHandlers :: TeamId -> [KeyEventHandler]+reactionEmojiListWindowKeyHandlers tId =+ [ mkKb CancelEvent "Close the emoji search window"+ (exitListWindow tId (csTeam(tId).tsReactionEmojiListWindow))+ , mkKb SearchSelectUpEvent "Select the previous emoji" $+ reactionEmojiListSelectUp tId+ , mkKb SearchSelectDownEvent "Select the next emoji" $+ reactionEmojiListSelectDown tId+ , mkKb PageDownEvent "Page down in the emoji list" $+ reactionEmojiListPageDown tId+ , mkKb PageUpEvent "Page up in the emoji list" $+ reactionEmojiListPageUp tId+ , mkKb ActivateListItemEvent "Post the selected emoji reaction"+ (listWindowActivateCurrent tId (csTeam(tId).tsReactionEmojiListWindow))+ ]
src/Matterhorn/Events/SaveAttachmentWindow.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.Events.SaveAttachmentWindow ( onEventSaveAttachmentWindow )@@ -11,36 +12,37 @@ import Brick.Focus import Brick.Widgets.Edit ( handleEditorEvent, getEditContents ) import qualified Data.Text as T-import Lens.Micro.Platform ( (%=) )+import Lens.Micro.Platform ( (%=), Lens' ) import qualified Graphics.Vty as Vty -import Network.Mattermost.Types ( TeamId )- import Matterhorn.Types+import Matterhorn.State.SaveAttachmentWindow import Matterhorn.State.Common ( postInfoMessage, fetchFileAtPath , doAsyncWith, AsyncPriority(Normal) , postErrorMessage' ) -onEventSaveAttachmentWindow :: TeamId -> Vty.Event -> MH ()-onEventSaveAttachmentWindow tId (Vty.EvKey (Vty.KChar '\t') []) =- csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus %= focusNext-onEventSaveAttachmentWindow tId (Vty.EvKey Vty.KBackTab []) =- csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus %= focusPrev-onEventSaveAttachmentWindow tId (Vty.EvKey Vty.KEnter []) = do- f <- use (csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus)+onEventSaveAttachmentWindow :: Lens' ChatState (MessageInterface Name i) -> Vty.Event -> MH Bool+onEventSaveAttachmentWindow which (Vty.EvKey (Vty.KChar '\t') []) = do+ which.miSaveAttachmentDialog.attachmentPathDialogFocus %= focusNext+ return True+onEventSaveAttachmentWindow which (Vty.EvKey Vty.KBackTab []) = do+ which.miSaveAttachmentDialog.attachmentPathDialogFocus %= focusPrev+ return True+onEventSaveAttachmentWindow which (Vty.EvKey Vty.KEnter []) = do+ f <- use (which.miSaveAttachmentDialog.attachmentPathDialogFocus) session <- getSession- mode <- use (csTeam(tId).tsMode)+ mode <- use (which.miMode) let link = case mode of- SaveAttachmentWindow l -> l+ SaveAttachment l -> l _ -> error $ "BUG: invalid mode " <> show mode <> " in onEventSaveAttachmentWindow" fId = case link^.linkTarget of LinkFileId i -> i _ -> error $ "BUG: invalid link target " <> show (link^.linkTarget) <> " in onEventSaveAttachmentWindow" save = do- ed <- use (csTeam(tId).tsSaveAttachmentDialog.attachmentPathEditor)+ ed <- use (which.miSaveAttachmentDialog.attachmentPathEditor) let path = T.unpack $ T.strip $ T.concat $ getEditContents ed when (not $ null path) $ do@@ -52,20 +54,24 @@ postErrorMessage' $ T.pack $ "Error saving to " <> path <> ": " <> show e Right () -> postInfoMessage $ T.pack $ "Attachment saved to " <> path- setMode tId UrlSelect+ closeSaveAttachmentWindow which case focusGetCurrent f of Just (AttachmentPathSaveButton {}) -> save Just (AttachmentPathEditor {}) -> save- Just (AttachmentPathCancelButton {}) -> setMode tId UrlSelect- _ -> setMode tId UrlSelect-onEventSaveAttachmentWindow tId (Vty.EvKey Vty.KEsc []) = do- setMode tId UrlSelect-onEventSaveAttachmentWindow tId e = do- f <- use (csTeam(tId).tsSaveAttachmentDialog.attachmentPathDialogFocus)+ Just (AttachmentPathCancelButton {}) -> closeSaveAttachmentWindow which+ _ -> closeSaveAttachmentWindow which++ return True+onEventSaveAttachmentWindow which (Vty.EvKey Vty.KEsc []) = do+ closeSaveAttachmentWindow which+ return True+onEventSaveAttachmentWindow which e = do+ f <- use (which.miSaveAttachmentDialog.attachmentPathDialogFocus) case focusGetCurrent f of- Just (AttachmentPathEditor {}) ->- mhHandleEventLensed (csTeam(tId).tsSaveAttachmentDialog.attachmentPathEditor)+ Just (AttachmentPathEditor {}) -> do+ mhHandleEventLensed (which.miSaveAttachmentDialog.attachmentPathEditor) handleEditorEvent e+ return True _ ->- return ()+ return False
src/Matterhorn/Events/ShowHelp.hs view
@@ -15,10 +15,16 @@ onEventShowHelp :: TeamId -> Vty.Event -> MH Bool onEventShowHelp tId =- handleKeyboardEvent (helpKeybindings tId) $ \ e -> case e of- Vty.EvKey _ _ -> popMode tId- _ -> return ()+ handleEventWith [ handleKeyboardEvent (helpKeybindings tId)+ , closeHelp tId+ ] +closeHelp :: TeamId -> Vty.Event -> MH Bool+closeHelp tId (Vty.EvKey {}) = do+ popMode tId+ return True+closeHelp _ _ = return False+ helpKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap helpKeybindings tId = mkKeybindings (helpKeyHandlers tId) @@ -32,15 +38,10 @@ mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount) , mkKb PageDownEvent "Page down" $ mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount)- , mkKb CancelEvent "Return to the previous interface" $+ , mkKb CancelEvent "Close the help window" $ popMode tId , mkKb ScrollBottomEvent "Scroll to the end of the help" $ mh $ vScrollToEnd (viewportScroll HelpViewport) , mkKb ScrollTopEvent "Scroll to the beginning of the help" $ mh $ vScrollToBeginning (viewportScroll HelpViewport) ]--popMode :: TeamId -> MH ()-popMode tId = do- ShowHelp _ prevMode <- use (csTeam(tId).tsMode)- setMode tId prevMode
src/Matterhorn/Events/TabbedWindow.hs view
@@ -19,16 +19,18 @@ import Matterhorn.Events.Keybindings handleTabbedWindowEvent :: (Show a, Eq a)- => Lens' ChatState (TabbedWindow a)+ => Lens' ChatState (TabbedWindow ChatState MH Name a) -> TeamId -> Vty.Event -> MH Bool handleTabbedWindowEvent target tId e = do w <- use target- handleKeyboardEvent (tabbedWindowKeybindings target tId) (forwardEvent w) e+ handleEventWith [ handleKeyboardEvent (tabbedWindowKeybindings target tId)+ , \_ -> forwardEvent w e >> return True+ ] e forwardEvent :: (Show a, Eq a)- => TabbedWindow a+ => TabbedWindow s MH n a -> Vty.Event -> MH () forwardEvent w e = do@@ -36,7 +38,7 @@ tweHandleEvent cur (twValue w) e tabbedWindowKeybindings :: (Show a, Eq a)- => Lens' ChatState (TabbedWindow a)+ => Lens' ChatState (TabbedWindow ChatState MH Name a) -> TeamId -> KeyConfig -> KeyHandlerMap@@ -44,12 +46,11 @@ tabbedWindowKeyHandlers :: (Show a, Eq a) => TeamId- -> Lens' ChatState (TabbedWindow a)+ -> Lens' ChatState (TabbedWindow ChatState MH Name a) -> [KeyEventHandler] tabbedWindowKeyHandlers tId target =- [ mkKb CancelEvent "Close window" $ do- w <- use target- setMode tId (twReturnMode w)+ [ mkKb CancelEvent "Close window" $+ popMode tId , mkKb SelectNextTabEvent "Select next tab" $ do w' <- tabbedWindowNextTab =<< use target
− src/Matterhorn/Events/ThemeListOverlay.hs
@@ -1,39 +0,0 @@-module Matterhorn.Events.ThemeListOverlay where--import Prelude ()-import Matterhorn.Prelude--import qualified Graphics.Vty as Vty--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Events.Keybindings-import Matterhorn.State.ThemeListOverlay-import Matterhorn.State.ListOverlay-import Matterhorn.Types---onEventThemeListOverlay :: TeamId -> Vty.Event -> MH ()-onEventThemeListOverlay tId =- void . onEventListOverlay tId (csTeam(tId).tsThemeListOverlay)- (themeListOverlayKeybindings tId)---- | The keybindings we want to use while viewing a user list overlay-themeListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-themeListOverlayKeybindings tId = mkKeybindings (themeListOverlayKeyHandlers tId)--themeListOverlayKeyHandlers :: TeamId -> [KeyEventHandler]-themeListOverlayKeyHandlers tId =- [ mkKb CancelEvent "Close the theme list"- (exitListOverlay tId (csTeam(tId).tsThemeListOverlay))- , mkKb SearchSelectUpEvent "Select the previous theme" $- themeListSelectUp tId- , mkKb SearchSelectDownEvent "Select the next theme" $- themeListSelectDown tId- , mkKb PageDownEvent "Page down in the theme list" $- themeListPageDown tId- , mkKb PageUpEvent "Page up in the theme list" $- themeListPageUp tId- , mkKb ActivateListItemEvent "Switch to the selected color theme"- (listOverlayActivateCurrent tId (csTeam(tId).tsThemeListOverlay))- ]
+ src/Matterhorn/Events/ThemeListWindow.hs view
@@ -0,0 +1,39 @@+module Matterhorn.Events.ThemeListWindow where++import Prelude ()+import Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Events.Keybindings+import Matterhorn.State.ThemeListWindow+import Matterhorn.State.ListWindow+import Matterhorn.Types+++onEventThemeListWindow :: TeamId -> Vty.Event -> MH ()+onEventThemeListWindow tId =+ void . onEventListWindow (csTeam(tId).tsThemeListWindow)+ (themeListWindowKeybindings tId)++-- | The keybindings we want to use while viewing a user list window+themeListWindowKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap+themeListWindowKeybindings tId = mkKeybindings (themeListWindowKeyHandlers tId)++themeListWindowKeyHandlers :: TeamId -> [KeyEventHandler]+themeListWindowKeyHandlers tId =+ [ mkKb CancelEvent "Close the theme list"+ (exitListWindow tId (csTeam(tId).tsThemeListWindow))+ , mkKb SearchSelectUpEvent "Select the previous theme" $+ themeListSelectUp tId+ , mkKb SearchSelectDownEvent "Select the next theme" $+ themeListSelectDown tId+ , mkKb PageDownEvent "Page down in the theme list" $+ themeListPageDown tId+ , mkKb PageUpEvent "Page up in the theme list" $+ themeListPageUp tId+ , mkKb ActivateListItemEvent "Switch to the selected color theme"+ (listWindowActivateCurrent tId (csTeam(tId).tsThemeListWindow))+ ]
+ src/Matterhorn/Events/ThreadWindow.hs view
@@ -0,0 +1,22 @@+module Matterhorn.Events.ThreadWindow+ ( onEventThreadWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Graphics.Vty as Vty+import Lens.Micro.Platform (Lens')++import Network.Mattermost.Types (TeamId)++import Matterhorn.Types+import Matterhorn.Events.MessageInterface++onEventThreadWindow :: TeamId -> Vty.Event -> MH Bool+onEventThreadWindow tId ev = do+ let ti :: Lens' ChatState ThreadInterface+ ti = unsafeThreadInterface tId++ handleMessageInterfaceEvent tId ti ev
src/Matterhorn/Events/UrlSelect.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.Events.UrlSelect where import Prelude ()@@ -5,8 +6,7 @@ import Brick.Widgets.List import qualified Graphics.Vty as Vty--import Network.Mattermost.Types ( TeamId )+import Lens.Micro.Platform ( Lens' ) import Matterhorn.Events.Keybindings import Matterhorn.State.UrlSelect@@ -14,32 +14,33 @@ import Matterhorn.Types -onEventUrlSelect :: TeamId -> Vty.Event -> MH Bool-onEventUrlSelect tId =- handleKeyboardEvent (urlSelectKeybindings tId) $ \ ev ->- mhHandleEventLensed (csTeam(tId).tsUrlList) handleListEvent ev+onEventUrlSelect :: Lens' ChatState (MessageInterface Name i) -> Vty.Event -> MH Bool+onEventUrlSelect which =+ handleEventWith [ handleKeyboardEvent (urlSelectKeybindings which)+ , \e -> mhHandleEventLensed (which.miUrlList.ulList) handleListEvent e >> return True+ ] -urlSelectKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-urlSelectKeybindings tId = mkKeybindings (urlSelectKeyHandlers tId)+urlSelectKeybindings :: Lens' ChatState (MessageInterface Name i) -> KeyConfig -> KeyHandlerMap+urlSelectKeybindings which = mkKeybindings (urlSelectKeyHandlers which) -urlSelectKeyHandlers :: TeamId -> [KeyEventHandler]-urlSelectKeyHandlers tId =+urlSelectKeyHandlers :: Lens' ChatState (MessageInterface Name i) -> [KeyEventHandler]+urlSelectKeyHandlers which = [ staticKb "Open the selected URL, if any" (Vty.EvKey Vty.KEnter []) $- openSelectedURL tId+ openSelectedURL which , mkKb SaveAttachmentEvent "Save the selected attachment" $- openSaveAttachmentWindow tId+ openSaveAttachmentWindow which - , mkKb CancelEvent "Cancel URL selection" $ stopUrlSelect tId+ , mkKb CancelEvent "Cancel URL selection" $ stopUrlSelect which , mkKb SelectUpEvent "Move cursor up" $- mhHandleEventLensed (csTeam(tId).tsUrlList) handleListEvent (Vty.EvKey Vty.KUp [])+ mhHandleEventLensed (which.miUrlList.ulList) handleListEvent (Vty.EvKey Vty.KUp []) , mkKb SelectDownEvent "Move cursor down" $- mhHandleEventLensed (csTeam(tId).tsUrlList) handleListEvent (Vty.EvKey Vty.KDown [])+ mhHandleEventLensed (which.miUrlList.ulList) handleListEvent (Vty.EvKey Vty.KDown []) , staticKb "Cancel URL selection"- (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect tId+ (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect which ]
− src/Matterhorn/Events/UserListOverlay.hs
@@ -1,32 +0,0 @@-module Matterhorn.Events.UserListOverlay where--import Prelude ()-import Matterhorn.Prelude--import qualified Graphics.Vty as Vty--import Network.Mattermost.Types ( TeamId )--import Matterhorn.Events.Keybindings-import Matterhorn.State.UserListOverlay-import Matterhorn.State.ListOverlay-import Matterhorn.Types---onEventUserListOverlay :: TeamId -> Vty.Event -> MH ()-onEventUserListOverlay tId =- void . onEventListOverlay tId (csTeam(tId).tsUserListOverlay) (userListOverlayKeybindings tId)---- | The keybindings we want to use while viewing a user list overlay-userListOverlayKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-userListOverlayKeybindings tId = mkKeybindings (userListOverlayKeyHandlers tId)--userListOverlayKeyHandlers :: TeamId -> [KeyEventHandler]-userListOverlayKeyHandlers tId =- [ mkKb CancelEvent "Close the user search list" (exitListOverlay tId (csTeam(tId).tsUserListOverlay))- , mkKb SearchSelectUpEvent "Select the previous user" $ userListSelectUp tId- , mkKb SearchSelectDownEvent "Select the next user" $ userListSelectDown tId- , mkKb PageDownEvent "Page down in the user list" $ userListPageDown tId- , mkKb PageUpEvent "Page up in the user list" $ userListPageUp tId- , mkKb ActivateListItemEvent "Interact with the selected user" (listOverlayActivateCurrent tId (csTeam(tId).tsUserListOverlay))- ]
+ src/Matterhorn/Events/UserListWindow.hs view
@@ -0,0 +1,32 @@+module Matterhorn.Events.UserListWindow where++import Prelude ()+import Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import Network.Mattermost.Types ( TeamId )++import Matterhorn.Events.Keybindings+import Matterhorn.State.UserListWindow+import Matterhorn.State.ListWindow+import Matterhorn.Types+++onEventUserListWindow :: TeamId -> Vty.Event -> MH ()+onEventUserListWindow tId =+ void . onEventListWindow (csTeam(tId).tsUserListWindow) (userListWindowKeybindings tId)++-- | The keybindings we want to use while viewing a user list window+userListWindowKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap+userListWindowKeybindings tId = mkKeybindings (userListWindowKeyHandlers tId)++userListWindowKeyHandlers :: TeamId -> [KeyEventHandler]+userListWindowKeyHandlers tId =+ [ mkKb CancelEvent "Close the user search list" (exitListWindow tId (csTeam(tId).tsUserListWindow))+ , mkKb SearchSelectUpEvent "Select the previous user" $ userListSelectUp tId+ , mkKb SearchSelectDownEvent "Select the next user" $ userListSelectDown tId+ , mkKb PageDownEvent "Page down in the user list" $ userListPageDown tId+ , mkKb PageUpEvent "Page up in the user list" $ userListPageUp tId+ , mkKb ActivateListItemEvent "Interact with the selected user" (listWindowActivateCurrent tId (csTeam(tId).tsUserListWindow))+ ]
src/Matterhorn/Events/Websocket.hs view
@@ -120,7 +120,7 @@ WMTyping | Just uId <- wepUserId $ weData we- , Just cId <- webChannelId (weBroadcast we) -> handleTypingUser uId cId+ , Just cId <- webChannelId (weBroadcast we) -> handleTypingUser uId cId (wepParentId $ weData we) | otherwise -> return () WMChannelDeleted
src/Matterhorn/HelpTopics.hs view
@@ -24,25 +24,23 @@ mainHelpTopic :: HelpTopic mainHelpTopic =- HelpTopic "main" "This help page" MainHelp HelpText+ HelpTopic "main" "This help page" MainHelp scriptHelpTopic :: HelpTopic scriptHelpTopic =- HelpTopic "scripts" "Help on available scripts" ScriptHelp ScriptHelpText+ HelpTopic "scripts" "Help on available scripts" ScriptHelp themeHelpTopic :: HelpTopic themeHelpTopic =- HelpTopic "themes" "Help on color themes" ThemeHelp ThemeHelpText+ HelpTopic "themes" "Help on color themes" ThemeHelp keybindingHelpTopic :: HelpTopic keybindingHelpTopic =- HelpTopic "keybindings" "Help on overriding keybindings"- KeybindingHelp KeybindingHelpText+ HelpTopic "keybindings" "Help on overriding keybindings" KeybindingHelp syntaxHighlightingHelpTopic :: HelpTopic syntaxHighlightingHelpTopic =- HelpTopic "syntax" "Help on syntax highlighing"- SyntaxHighlightHelp SyntaxHighlightHelpText+ HelpTopic "syntax" "Help on syntax highlighing" SyntaxHighlightHelp lookupHelpTopic :: Text -> Maybe HelpTopic lookupHelpTopic topic =
src/Matterhorn/LastRunState.hs view
@@ -5,6 +5,7 @@ , lrsPort , lrsUserId , lrsSelectedChannelId+ , lrsOpenThread , writeLastRunStates , readLastRunState , isValidLastRunState@@ -40,6 +41,7 @@ , _lrsPort :: Port -- ^ Post of the server , _lrsUserId :: UserId -- ^ ID of the logged-in user , _lrsSelectedChannelId :: Maybe ChannelId -- ^ ID of the last selected channel+ , _lrsOpenThread :: Maybe (ChannelId, PostId) } instance A.ToJSON LastRunState where@@ -47,6 +49,7 @@ , "port" A..= _lrsPort lrs , "user_id" A..= _lrsUserId lrs , "sel_channel_id" A..= _lrsSelectedChannelId lrs+ , "open_thread" A..= _lrsOpenThread lrs ] instance A.FromJSON LastRunState where@@ -56,6 +59,7 @@ <*> v A..: "port" <*> v A..: "user_id" <*> v A..: "sel_channel_id"+ <*> v A..:? "open_thread" makeLenses ''LastRunState @@ -65,6 +69,9 @@ , _lrsPort = cs^.csResources.crConn.cdPortL , _lrsUserId = myUserId cs , _lrsSelectedChannelId = cs^.csCurrentChannelId(tId)+ , _lrsOpenThread = do+ ti <- cs^.csTeam(tId).tsThreadInterface+ return (ti^.miChannelId, ti^.miRootPostId) } lastRunStateFileMode :: P.FileMode
src/Matterhorn/Scripts.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.Scripts ( findAndRunScript , listScripts@@ -10,23 +11,22 @@ import Control.Concurrent ( takeMVar, newEmptyMVar ) import qualified Control.Concurrent.STM as STM import qualified Data.Text as T+import Lens.Micro.Platform ( Lens' ) import System.Exit ( ExitCode(..) ) -import Network.Mattermost.Types ( TeamId, ChannelId )- import Matterhorn.FilePaths ( Script(..), getAllScripts, locateScriptPath ) import Matterhorn.State.Common import Matterhorn.State.Messages ( sendMessage ) import Matterhorn.Types -findAndRunScript :: TeamId -> ChannelId -> Text -> Text -> MH ()-findAndRunScript tId cId scriptName input = do+findAndRunScript :: Lens' ChatState (EditState Name) -> Text -> Text -> MH ()+findAndRunScript which scriptName input = do fpMb <- liftIO $ locateScriptPath (T.unpack scriptName) outputChan <- use (csResources.crSubprocessLog) case fpMb of ScriptPath scriptPath -> do- doAsyncWith Preempt $ runScript tId cId outputChan scriptPath input+ doAsyncWith Preempt $ runScript which outputChan scriptPath input NonexecScriptPath scriptPath -> do let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <> "executed. Try running\n" <>@@ -38,8 +38,12 @@ ScriptNotFound -> do mhError $ NoSuchScript scriptName -runScript :: TeamId -> ChannelId -> STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))-runScript tId cId outputChan fp text = do+runScript :: Lens' ChatState (EditState Name)+ -> STM.TChan ProgramOutput+ -> FilePath+ -> Text+ -> IO (Maybe (MH ()))+runScript which outputChan fp text = do outputVar <- newEmptyMVar runLoggedCommand outputChan fp [] (Just $ T.unpack text) (Just outputVar) po <- takeMVar outputVar@@ -47,7 +51,8 @@ ExitSuccess -> do case null $ programStderr po of True -> Just $ do- mode <- use (csTeam(tId).tsEditState.cedEditMode)+ mode <- use (which.esEditMode)+ cId <- use (which.esChannelId) sendMessage cId mode (T.pack $ programStdout po) [] False -> Nothing ExitFailure _ -> Nothing
src/Matterhorn/State/Async.hs view
@@ -8,6 +8,7 @@ , doAsyncMM , tryMM , endAsyncNOP+ , scheduleMH ) where @@ -107,6 +108,11 @@ doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO () doAsyncIO prio st act = doAsyncWithIO prio st (act >> return Nothing)++scheduleMH :: ChatResources -> MH () -> IO ()+scheduleMH r act = do+ let queue = r^.crRequestQueue+ STM.atomically $ STM.writeTChan queue $ return $ Just act -- | Run a computation in the background, returning a computation to be -- called on the 'ChatState' value.
src/Matterhorn/State/Attachments.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.Attachments ( showAttachmentList- , resetAttachmentList , showAttachmentFileBrowser , attachFileByPath , tryAddAttachment@@ -12,7 +12,6 @@ import Prelude () import Matterhorn.Prelude -import Brick ( vScrollToBeginning, viewportScroll ) import qualified Brick.Widgets.List as L import qualified Brick.Widgets.FileBrowser as FB import qualified Control.Exception as E@@ -22,11 +21,9 @@ import Data.Text ( unpack ) import qualified Data.Vector as Vector import GHC.Exception ( toException )-import Lens.Micro.Platform ( (.=), (%=) )+import Lens.Micro.Platform ( (.=), (%=), Lens' ) import System.Directory ( doesDirectoryExist, doesFileExist, getDirectoryContents ) -import Network.Mattermost.Types ( TeamId )- import Matterhorn.Types validateAttachmentPath :: FilePath -> IO (Maybe FilePath)@@ -42,41 +39,36 @@ defaultAttachmentsPath :: Config -> IO (Maybe FilePath) defaultAttachmentsPath = maybe (return Nothing) validateAttachmentPath . configDefaultAttachmentPath -showAttachmentList :: TeamId -> MH ()-showAttachmentList tId = do- lst <- use (csTeam(tId).tsEditState.cedAttachmentList)+showAttachmentList :: Lens' ChatState (MessageInterface Name i) -> MH ()+showAttachmentList which = do+ lst <- use (which.miEditor.esAttachmentList) case length (L.listElements lst) of- 0 -> showAttachmentFileBrowser tId- _ -> setMode tId ManageAttachments--resetAttachmentList :: TeamId -> MH ()-resetAttachmentList tId = do- let listName = AttachmentList tId- csTeam(tId).tsEditState.cedAttachmentList .= L.list listName mempty 1- mh $ vScrollToBeginning $ viewportScroll listName+ 0 -> showAttachmentFileBrowser which+ _ -> which.miMode .= ManageAttachments -showAttachmentFileBrowser :: TeamId -> MH ()-showAttachmentFileBrowser tId = do+showAttachmentFileBrowser :: Lens' ChatState (MessageInterface Name i) -> MH ()+showAttachmentFileBrowser which = do+ cId <- use (which.miEditor.esChannelId) config <- use (csResources.crConfiguration) filePath <- liftIO $ defaultAttachmentsPath config- browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser tId) filePath- csTeam(tId).tsEditState.cedFileBrowser .= browser- setMode tId ManageAttachmentsBrowseFiles+ browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories (AttachmentFileBrowser cId) filePath+ which.miEditor.esFileBrowser .= browser+ which.miMode .= BrowseFiles -attachFileByPath :: TeamId -> Text -> MH ()-attachFileByPath tId txtPath = do+attachFileByPath :: Lens' ChatState (MessageInterface Name i) -> Text -> MH ()+attachFileByPath which txtPath = do let strPath = unpack txtPath fileInfo <- liftIO $ FB.getFileInfo strPath strPath case FB.fileInfoFileStatus fileInfo of Left e -> do mhError $ AttachmentException (toException e)- Right _ -> tryAddAttachment tId [fileInfo]+ Right _ -> tryAddAttachment which [fileInfo] checkPathIsFile :: FB.FileInfo -> MH Bool checkPathIsFile = liftIO . doesFileExist . FB.fileInfoFilePath -tryAddAttachment :: TeamId -> [FB.FileInfo] -> MH ()-tryAddAttachment tId entries = do+tryAddAttachment :: Lens' ChatState (MessageInterface Name i) -> [FB.FileInfo] -> MH ()+tryAddAttachment which entries = do forM_ entries $ \entry -> do isFile <- checkPathIsFile entry if not isFile@@ -84,7 +76,7 @@ "Error attaching file. It either doesn't exist or is a directory, which is not supported.") else do -- Is the entry already present? If so, ignore the selection.- es <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL)+ es <- use (which.miEditor.esAttachmentList.L.listElementsL) let matches = (== FB.fileInfoFilePath entry) . FB.fileInfoFilePath . attachmentDataFileInfo@@ -93,14 +85,15 @@ Nothing -> do tryReadAttachment entry >>= \case Right a -> do- oldIdx <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listSelectedL)+ oldIdx <- use (which.miEditor.esAttachmentList.L.listSelectedL) let newIdx = if Vector.null es then Just 0 else oldIdx- csTeam(tId).tsEditState.cedAttachmentList %= L.listReplace (Vector.snoc es a) newIdx+ which.miEditor.esAttachmentList %= L.listReplace (Vector.snoc es a) newIdx Left e -> mhError $ AttachmentException e - when (not $ null entries) $ setMode tId Main+ when (not $ null entries) $+ which.miMode .= Compose tryReadAttachment :: FB.FileInfo -> MH (Either E.SomeException AttachmentData) tryReadAttachment fi = do
src/Matterhorn/State/Autocomplete.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.Autocomplete ( AutocompleteContext(..) , checkForAutocompletion@@ -7,6 +8,7 @@ import Prelude () import Matterhorn.Prelude +import Brick ( getName ) import Brick.Main ( viewportScroll, vScrollToBeginning ) import Brick.Widgets.Edit ( editContentsL ) import qualified Brick.Widgets.List as L@@ -15,11 +17,12 @@ import qualified Data.HashMap.Strict as HM import Data.List ( sortBy, partition ) import qualified Data.Map as M+import Data.Maybe ( fromJust ) import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Data.Text.Zipper as Z import qualified Data.Vector as V-import Lens.Micro.Platform ( (%=), (.=), (.~), _Just )+import Lens.Micro.Platform ( (%=), (.=), (.~), _Just, Traversal' ) import qualified Skylighting.Types as Sky import Network.Mattermost.Types (userId, channelId, Command(..), TeamId)@@ -55,13 +58,16 @@ -- should cause an autocompletion UI to appear. If so, initiate a server -- query or local cache lookup to present the completion alternatives -- for the word at the cursor.-checkForAutocompletion :: TeamId -> AutocompleteContext -> MH ()-checkForAutocompletion tId ctx = do- result <- getCompleterForInput tId ctx+checkForAutocompletion :: Traversal' ChatState (EditState Name)+ -> AutocompleteContext+ -> MH ()+checkForAutocompletion which ctx = do+ result <- getCompleterForInput which ctx case result of- Nothing -> resetAutocomplete tId+ Nothing -> resetAutocomplete which Just (ty, runUpdater, searchString) -> do- prevResult <- use (csTeam(tId).tsEditState.cedAutocomplete)+ prevResult <- join <$> preuse (which.esAutocomplete)+ -- We should update the completion state if EITHER: -- -- 1) The type changed@@ -74,53 +80,68 @@ (maybe True ((== ty) . _acType) prevResult)) || (maybe False ((/= ty) . _acType) prevResult) when shouldUpdate $ do- csTeam(tId).tsEditState.cedAutocompletePending .= Just searchString+ which.esAutocompletePending .= Just searchString runUpdater ty ctx searchString -getCompleterForInput :: TeamId+getCompleterForInput :: Traversal' ChatState (EditState Name) -> AutocompleteContext -> MH (Maybe (AutocompletionType, AutocompletionType -> AutocompleteContext -> Text -> MH (), Text))-getCompleterForInput tId ctx = do- z <- use (csTeam(tId).tsEditState.cedEditor.editContentsL)-- let col = snd $ Z.cursorPosition z- curLine = Z.currentLine z+getCompleterForInput which ctx = do+ maybeZipper <- preuse (which.esEditor.editContentsL)+ mmTid <- preuse (which.esTeamId)+ tId <- do+ case mmTid of+ Just (Just i) -> return i+ _ -> fromJust <$> use csCurrentTeamId+ case maybeZipper of+ Just z -> do+ let col = snd $ Z.cursorPosition z+ curLine = Z.currentLine z - return $ case wordAtColumn col curLine of- Just (startCol, w)- | userSigil `T.isPrefixOf` w ->- Just (ACUsers, doUserAutoCompletion tId, T.tail w)- | normalChannelSigil `T.isPrefixOf` w ->- Just (ACChannels, doChannelAutoCompletion tId, T.tail w)- | ":" `T.isPrefixOf` w && autocompleteManual ctx ->- Just (ACEmoji, doEmojiAutoCompletion tId, T.tail w)- | "```" `T.isPrefixOf` w ->- Just (ACCodeBlockLanguage, doSyntaxAutoCompletion tId, T.drop 3 w)- | "/" `T.isPrefixOf` w && startCol == 0 ->- Just (ACCommands, doCommandAutoCompletion tId, T.tail w)- _ -> Nothing+ return $ case wordAtColumn col curLine of+ Just (startCol, w)+ | userSigil `T.isPrefixOf` w ->+ Just (ACUsers, doUserAutoCompletion which tId, T.tail w)+ | normalChannelSigil `T.isPrefixOf` w ->+ Just (ACChannels, doChannelAutoCompletion tId which, T.tail w)+ | ":" `T.isPrefixOf` w && autocompleteManual ctx ->+ Just (ACEmoji, doEmojiAutoCompletion which, T.tail w)+ | "```" `T.isPrefixOf` w ->+ Just (ACCodeBlockLanguage, doSyntaxAutoCompletion which, T.drop 3 w)+ | "/" `T.isPrefixOf` w && startCol == 0 ->+ Just (ACCommands, doCommandAutoCompletion which tId, T.tail w)+ _ -> Nothing+ _ -> return Nothing -- Completion implementations -doEmojiAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH ()-doEmojiAutoCompletion tId ty ctx searchString = do+doEmojiAutoCompletion :: Traversal' ChatState (EditState Name)+ -> AutocompletionType+ -> AutocompleteContext+ -> Text+ -> MH ()+doEmojiAutoCompletion which ty ctx searchString = do session <- getSession em <- use (csResources.crEmoji)- withCachedAutocompleteResults tId ctx ty searchString $+ withCachedAutocompleteResults which ctx ty searchString $ doAsyncWith Preempt $ do results <- getMatchingEmoji session em searchString let alts = EmojiCompletion <$> results- return $ Just $ setCompletionAlternatives tId ctx searchString alts ty+ return $ Just $ setCompletionAlternatives which ctx searchString alts ty -doSyntaxAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH ()-doSyntaxAutoCompletion tId ty ctx searchString = do+doSyntaxAutoCompletion :: Traversal' ChatState (EditState Name)+ -> AutocompletionType+ -> AutocompleteContext+ -> Text+ -> MH ()+doSyntaxAutoCompletion which ty ctx searchString = do mapping <- use (csResources.crSyntaxMap) let allNames = Sky.sShortname <$> M.elems mapping (prefixed, notPrefixed) = partition isPrefixed $ filter match allNames match = (((T.toLower searchString) `T.isInfixOf`) . T.toLower) isPrefixed = (((T.toLower searchString) `T.isPrefixOf`) . T.toLower) alts = SyntaxCompletion <$> (sort prefixed <> sort notPrefixed)- setCompletionAlternatives tId ctx searchString alts ty+ setCompletionAlternatives which ctx searchString alts ty -- | This list of server commands should be hidden because they make -- assumptions about a web-based client or otherwise just don't make@@ -169,12 +190,17 @@ isDeletedCommand :: Command -> Bool isDeletedCommand cmd = commandDeleteAt cmd > commandCreateAt cmd -doCommandAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH ()-doCommandAutoCompletion myTid ty ctx searchString = do+doCommandAutoCompletion :: Traversal' ChatState (EditState Name)+ -> TeamId+ -> AutocompletionType+ -> AutocompleteContext+ -> Text+ -> MH ()+doCommandAutoCompletion which tId ty ctx searchString = do session <- getSession - mCache <- preuse (csTeam(myTid).tsEditState.cedAutocomplete._Just.acCachedResponses)- mActiveTy <- preuse (csTeam(myTid).tsEditState.cedAutocomplete._Just.acType)+ mCache <- preuse (which.esAutocomplete._Just.acCachedResponses)+ mActiveTy <- preuse (which.esAutocomplete._Just.acType) -- Command completion works a little differently than the other -- modes. To do command autocompletion, we want to query the server@@ -210,7 +236,8 @@ mkAlt (Cmd name desc args _) = (Client, name, printArgSpec args, desc) - serverCommands <- MM.mmListCommandsForTeam myTid False session+ serverCommands <- MM.mmListCommandsForTeam tId False session+ let filteredServerCommands = filter (\c -> not (hiddenCommand c || isDeletedCommand c)) $ F.toList serverCommands@@ -228,19 +255,19 @@ return $ Just $ do -- Store the complete list of alterantives in the cache- setCompletionAlternatives myTid ctx serverResponseKey alts ty+ setCompletionAlternatives which ctx serverResponseKey alts ty -- Also store the list of alternatives specific to -- this search string let newAlts = sortBy (compareCommandAlts searchString) $ filter matches alts- setCompletionAlternatives myTid ctx searchString newAlts ty+ setCompletionAlternatives which ctx searchString newAlts ty else case entry of Just alts | mActiveTy == Just ACCommands -> let newAlts = sortBy (compareCommandAlts searchString) $ filter matches alts- in setCompletionAlternatives myTid ctx searchString newAlts ty+ in setCompletionAlternatives which ctx searchString newAlts ty _ -> return () compareCommandAlts :: Text -> AutocompleteAlternative -> AutocompleteAlternative -> Ordering@@ -255,43 +282,53 @@ else GT compareCommandAlts _ _ _ = LT -doUserAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH ()-doUserAutoCompletion tId ty ctx searchString = do+doUserAutoCompletion :: Traversal' ChatState (EditState Name)+ -> TeamId+ -> AutocompletionType+ -> AutocompleteContext+ -> Text+ -> MH ()+doUserAutoCompletion which tId ty ctx searchString = do session <- getSession myUid <- gets myUserId- withCurrentChannel tId $ \cId _ -> do- withCachedAutocompleteResults tId ctx ty searchString $- doAsyncWith Preempt $ do- ac <- MM.mmAutocompleteUsers (Just tId) (Just cId) searchString session+ Just cId <- preuse (which.esChannelId)+ withCachedAutocompleteResults which ctx ty searchString $+ doAsyncWith Preempt $ do+ ac <- MM.mmAutocompleteUsers (Just tId) (Just cId) searchString session - let active = Seq.filter (\u -> userId u /= myUid && (not $ userDeleted u))- alts = F.toList $- ((\u -> UserCompletion u True) <$> (active $ MM.userAutocompleteUsers ac)) <>- (maybe mempty (fmap (\u -> UserCompletion u False) . active) $- MM.userAutocompleteOutOfChannel ac)+ let active = Seq.filter (\u -> userId u /= myUid && (not $ userDeleted u))+ alts = F.toList $+ ((\u -> UserCompletion u True) <$> (active $ MM.userAutocompleteUsers ac)) <>+ (maybe mempty (fmap (\u -> UserCompletion u False) . active) $+ MM.userAutocompleteOutOfChannel ac) - specials = [ MentionAll- , MentionChannel- ]- extras = [ SpecialMention m | m <- specials- , (T.toLower searchString) `T.isPrefixOf` specialMentionName m- ]+ specials = [ MentionAll+ , MentionChannel+ ]+ extras = [ SpecialMention m | m <- specials+ , (T.toLower searchString) `T.isPrefixOf` specialMentionName m+ ] - return $ Just $ setCompletionAlternatives tId ctx searchString (alts <> extras) ty+ return $ Just $ setCompletionAlternatives which ctx searchString (alts <> extras) ty -doChannelAutoCompletion :: TeamId -> AutocompletionType -> AutocompleteContext -> Text -> MH ()-doChannelAutoCompletion tId ty ctx searchString = do+doChannelAutoCompletion :: TeamId+ -> Traversal' ChatState (EditState Name)+ -> AutocompletionType+ -> AutocompleteContext+ -> Text+ -> MH ()+doChannelAutoCompletion tId which ty ctx searchString = do session <- getSession cs <- use csChannels - withCachedAutocompleteResults tId ctx ty searchString $ do+ withCachedAutocompleteResults which ctx ty searchString $ do doAsyncWith Preempt $ do results <- MM.mmAutocompleteChannels tId searchString session let alts = F.toList $ (ChannelCompletion True <$> inChannels) <> (ChannelCompletion False <$> notInChannels) (inChannels, notInChannels) = Seq.partition isMember results isMember c = isJust $ findChannelById (channelId c) cs- return $ Just $ setCompletionAlternatives tId ctx searchString alts ty+ return $ Just $ setCompletionAlternatives which ctx searchString alts ty -- Utility functions @@ -299,7 +336,7 @@ -- a given search string. If the cache contains no such entry (keyed -- on search string), run the specified action, which is assumed to be -- responsible for fetching the completion results from the server.-withCachedAutocompleteResults :: TeamId+withCachedAutocompleteResults :: Traversal' ChatState (EditState Name) -> AutocompleteContext -- ^ The autocomplete context -> AutocompletionType@@ -311,61 +348,66 @@ -> MH () -- ^ The action to execute on a cache miss -> MH ()-withCachedAutocompleteResults tId ctx ty searchString act = do- mCache <- preuse (csTeam(tId).tsEditState.cedAutocomplete._Just.acCachedResponses)- mActiveTy <- preuse (csTeam(tId).tsEditState.cedAutocomplete._Just.acType)+withCachedAutocompleteResults which ctx ty searchString act = do+ mCache <- preuse (which.esAutocomplete._Just.acCachedResponses)+ mActiveTy <- preuse (which.esAutocomplete._Just.acType) case Just ty == mActiveTy of True -> -- Does the cache have results for this search string? If -- so, use them; otherwise invoke the specified action. case HM.lookup searchString =<< mCache of- Just alts -> setCompletionAlternatives tId ctx searchString alts ty+ Just alts -> setCompletionAlternatives which ctx searchString alts ty Nothing -> act False -> act -setCompletionAlternatives :: TeamId+setCompletionAlternatives :: Traversal' ChatState (EditState Name) -> AutocompleteContext -> Text -> [AutocompleteAlternative] -> AutocompletionType -> MH ()-setCompletionAlternatives tId ctx searchString alts ty = do- let list = L.list (CompletionList tId) (V.fromList $ F.toList alts) 1- state = AutocompleteState { _acPreviousSearchString = searchString- , _acCompletionList =- list & L.listSelectedL .~ Nothing- , _acCachedResponses = HM.fromList [(searchString, alts)]- , _acType = ty- }+setCompletionAlternatives which ctx searchString alts ty = do+ mVal <- preuse which+ case mVal of+ Nothing -> return ()+ Just esVal -> do+ let list = L.list (CompletionList $ getName $ esVal^.esEditor) (V.fromList $ F.toList alts) 1+ pending = esVal^.esAutocompletePending+ state = AutocompleteState { _acPreviousSearchString = searchString+ , _acCompletionList =+ list & L.listSelectedL .~ Nothing+ , _acCachedResponses = HM.fromList [(searchString, alts)]+ , _acType = ty+ } - pending <- use (csTeam(tId).tsEditState.cedAutocompletePending)- case pending of- Just val | val == searchString -> do+ case pending of+ Just val | val == searchString -> do - -- If there is already state, update it, but also cache the- -- search results.- csTeam(tId).tsEditState.cedAutocomplete %= \prev ->- let newState = case prev of- Nothing ->- state- Just oldState ->- state & acCachedResponses .~- HM.insert searchString alts (oldState^.acCachedResponses)- in Just newState+ -- If there is already state, update it, but also cache the+ -- search results.+ which.esAutocomplete %= \prev ->+ let newState = case prev of+ Nothing ->+ state+ Just oldState ->+ state & acCachedResponses .~+ HM.insert searchString alts (oldState^.acCachedResponses)+ in Just newState - mh $ vScrollToBeginning $ viewportScroll $ CompletionList tId+ mh $ vScrollToBeginning $ viewportScroll $ CompletionList $ getName $ esVal^.esEditor - when (autocompleteFirstMatch ctx) $- tabComplete tId Forwards- _ ->- -- Do not update the state if this result does not- -- correspond to the search string we used most recently.- -- This happens when the editor changes faster than the- -- async completion responses arrive from the server. If we- -- don't check this, we show completion results that are- -- wrong for the editor state.- return ()+ when (autocompleteFirstMatch ctx) $+ tabComplete which Forwards+ _ ->+ -- Do not update the state if this result does not+ -- correspond to the search string we used most+ -- recently. This happens when the editor changes+ -- faster than the async completion responses arrive+ -- from the server. If we don't check this, we show+ -- completion results that are wrong for the editor+ -- state.+ return () wordAtColumn :: Int -> Text -> Maybe (Int, Text) wordAtColumn i t =
− src/Matterhorn/State/ChannelListOverlay.hs
@@ -1,84 +0,0 @@-module Matterhorn.State.ChannelListOverlay- ( enterChannelListOverlayMode-- , channelListSelectDown- , channelListSelectUp- , channelListPageDown- , channelListPageUp- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Brick.Widgets.List as L-import qualified Data.Vector as Vec-import qualified Data.Sequence as Seq-import Data.Function ( on )-import qualified Data.Text as T-import Lens.Micro.Platform ( to )--import Network.Mattermost.Types-import qualified Network.Mattermost.Endpoints as MM--import Matterhorn.State.ListOverlay-import Matterhorn.State.Channels-import Matterhorn.Types---enterChannelListOverlayMode :: TeamId -> MH ()-enterChannelListOverlayMode tId = do- myChannels <- use (csChannels.to (filteredChannelIds (const True)))- enterListOverlayMode tId (csTeam(tId).tsChannelListOverlay) ChannelListOverlay- AllChannels (enterHandler tId) (fetchResults tId myChannels)--enterHandler :: TeamId -> Channel -> MH Bool-enterHandler tId chan = do- joinChannel tId (getId chan)- return True--fetchResults :: TeamId- -> [ChannelId]- -- ^ The channels to exclude from the results- -> ChannelSearchScope- -- ^ The scope to search- -> Session- -- ^ The connection session- -> Text- -- ^ The search string- -> IO (Vec.Vector Channel)-fetchResults myTId exclude AllChannels session searchString = do- resultChans <- case T.null searchString of- True -> MM.mmGetPublicChannels myTId (Just 0) (Just 200) session- False -> MM.mmSearchChannels myTId searchString session- let filteredChans = Seq.filter (\ c -> not (channelId c `elem` exclude)) resultChans- sortedChans = Vec.fromList $ toList $ Seq.sortBy (compare `on` channelDisplayName) filteredChans- return sortedChans---- | Move the selection up in the channel list overlay by one channel.-channelListSelectUp :: TeamId -> MH ()-channelListSelectUp tId = channelListMove tId L.listMoveUp---- | Move the selection down in the channel list overlay by one channel.-channelListSelectDown :: TeamId -> MH ()-channelListSelectDown tId = channelListMove tId L.listMoveDown---- | Move the selection up in the channel list overlay by a page of channels--- (channelListPageSize).-channelListPageUp :: TeamId -> MH ()-channelListPageUp tId = channelListMove tId (L.listMoveBy (-1 * channelListPageSize))---- | Move the selection down in the channel list overlay by a page of channels--- (channelListPageSize).-channelListPageDown :: TeamId -> MH ()-channelListPageDown tId = channelListMove tId (L.listMoveBy channelListPageSize)---- | Transform the channel list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-channelListMove :: TeamId -> (L.List Name Channel -> L.List Name Channel) -> MH ()-channelListMove tId = listOverlayMove (csTeam(tId).tsChannelListOverlay)---- | The number of channels in a "page" for cursor movement purposes.-channelListPageSize :: Int-channelListPageSize = 10
+ src/Matterhorn/State/ChannelListWindow.hs view
@@ -0,0 +1,85 @@+module Matterhorn.State.ChannelListWindow+ ( enterChannelListWindowMode++ , channelListSelectDown+ , channelListSelectUp+ , channelListPageDown+ , channelListPageUp+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Data.Vector as Vec+import qualified Data.Sequence as Seq+import Data.Function ( on )+import qualified Data.Text as T+import Lens.Micro.Platform ( to )++import Network.Mattermost.Types+import qualified Network.Mattermost.Endpoints as MM++import Matterhorn.State.ListWindow+import Matterhorn.State.Channels+import Matterhorn.Types+++enterChannelListWindowMode :: TeamId -> MH ()+enterChannelListWindowMode tId = do+ myChannels <- use (csChannels.to (filteredChannelIds (const True)))+ enterListWindowMode tId (csTeam(tId).tsChannelListWindow) ChannelListWindow+ AllChannels (enterHandler tId) (fetchResults tId myChannels)++enterHandler :: TeamId -> Channel -> MH Bool+enterHandler tId chan = do+ joinChannel tId (getId chan)+ popMode tId+ return True++fetchResults :: TeamId+ -> [ChannelId]+ -- ^ The channels to exclude from the results+ -> ChannelSearchScope+ -- ^ The scope to search+ -> Session+ -- ^ The connection session+ -> Text+ -- ^ The search string+ -> IO (Vec.Vector Channel)+fetchResults myTId exclude AllChannels session searchString = do+ resultChans <- case T.null searchString of+ True -> MM.mmGetPublicChannels myTId (Just 0) (Just 200) session+ False -> MM.mmSearchChannels myTId searchString session+ let filteredChans = Seq.filter (\ c -> not (channelId c `elem` exclude)) resultChans+ sortedChans = Vec.fromList $ toList $ Seq.sortBy (compare `on` channelDisplayName) filteredChans+ return sortedChans++-- | Move the selection up in the channel list window by one channel.+channelListSelectUp :: TeamId -> MH ()+channelListSelectUp tId = channelListMove tId L.listMoveUp++-- | Move the selection down in the channel list window by one channel.+channelListSelectDown :: TeamId -> MH ()+channelListSelectDown tId = channelListMove tId L.listMoveDown++-- | Move the selection up in the channel list window by a page of channels+-- (channelListPageSize).+channelListPageUp :: TeamId -> MH ()+channelListPageUp tId = channelListMove tId (L.listMoveBy (-1 * channelListPageSize))++-- | Move the selection down in the channel list window by a page of channels+-- (channelListPageSize).+channelListPageDown :: TeamId -> MH ()+channelListPageDown tId = channelListMove tId (L.listMoveBy channelListPageSize)++-- | Transform the channel list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+channelListMove :: TeamId -> (L.List Name Channel -> L.List Name Channel) -> MH ()+channelListMove tId = listWindowMove (csTeam(tId).tsChannelListWindow)++-- | The number of channels in a "page" for cursor movement purposes.+channelListPageSize :: Int+channelListPageSize = 10
src/Matterhorn/State/ChannelSelect.hs view
@@ -23,7 +23,7 @@ beginChannelSelect :: MM.TeamId -> MH () beginChannelSelect tId = do- setMode tId ChannelSelect+ pushMode tId ChannelSelect csTeam(tId).tsChannelSelectState .= emptyChannelSelectState tId updateChannelSelectMatches tId
src/Matterhorn/State/ChannelTopicWindow.hs view
@@ -11,6 +11,7 @@ import Network.Mattermost.Types ( TeamId ) import Matterhorn.Types+import Matterhorn.State.Teams ( newChannelTopicDialog ) import Matterhorn.State.Channels ( getCurrentChannelTopic ) @@ -21,4 +22,4 @@ Nothing -> return () Just topic -> do csTeam(tId).tsChannelTopicDialog .= newChannelTopicDialog tId topic- setMode tId ChannelTopicWindow+ pushMode tId ChannelTopicWindow
src/Matterhorn/State/Channels.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.Channels ( updateViewed , refreshChannel@@ -22,8 +23,8 @@ , hideDMChannel , createGroupChannel , showGroupChannelPref- , channelHistoryForward- , channelHistoryBackward+ , inputHistoryForward+ , inputHistoryBackward , handleNewChannel , createOrdinaryChannel , handleChannelInvite@@ -77,7 +78,7 @@ import Lens.Micro.Platform import qualified Network.Mattermost.Endpoints as MM-import Network.Mattermost.Lenses+import Network.Mattermost.Lenses hiding ( Lens' ) import Network.Mattermost.Types import Matterhorn.Constants ( normalChannelSigil )@@ -86,6 +87,7 @@ import {-# SOURCE #-} Matterhorn.State.Messages ( fetchVisibleIfNeeded ) import Matterhorn.State.ChannelList import Matterhorn.State.Users+import {-# SOURCE #-} Matterhorn.State.Teams import Matterhorn.State.Flagging import Matterhorn.Types import Matterhorn.Types.Common@@ -327,9 +329,12 @@ Nothing -> return () Just tId -> setFocus tId (getId nc) Nothing -> do+ eventQueue <- use (csResources.crEventQueue)+ spellChecker <- use (csResources.crSpellChecker)+ -- Create a new ClientChannel structure cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>- makeClientChannel (me^.userIdL) nc+ makeClientChannel eventQueue spellChecker (me^.userIdL) (channelTeamId nc) nc st <- use id @@ -383,7 +388,7 @@ -- possible to do so. updateSidebar (cChannel^.ccInfo.cdTeamId) - mtId <- case cChannel^.ccInfo.cdTeamId of+ chanTeam <- case cChannel^.ccInfo.cdTeamId of Nothing -> use csCurrentTeamId Just i -> return $ Just i @@ -392,7 +397,7 @@ -- channel. Also consider the last join request -- state field in case this is an asynchronous -- channel addition triggered by a /join.- case mtId of+ case chanTeam of Nothing -> return () Just tId -> do pending1 <- checkPendingChannelChange tId (getId nc)@@ -445,7 +450,7 @@ -- the Mattermost server. Also update the channel name if it changed. updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH () updateChannelInfo cid new member = do- mh $ invalidateCacheEntry $ ChannelMessages cid+ invalidateChannelRenderingCache cid csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member withChannel cid $ \chan -> updateSidebar (chan^.ccInfo.cdTeamId)@@ -464,6 +469,7 @@ -> MH () setFocusWith tId updatePrev f onChange onNoChange = do oldZipper <- use (csTeam(tId).tsFocus)+ mOldCid <- use (csCurrentChannelId tId) let newZipper = f oldZipper newFocus = Z.focus newZipper oldFocus = Z.focus oldZipper@@ -473,7 +479,11 @@ if newFocus /= oldFocus then do mh $ invalidateCacheEntry $ ChannelSidebar tId- resetAutocomplete tId++ case mOldCid of+ Nothing -> return ()+ Just cId -> resetAutocomplete (channelEditor(cId))+ preChangeChannelCommon tId csTeam(tId).tsFocus .= newZipper @@ -496,61 +506,36 @@ postChangeChannelCommon :: TeamId -> MH () postChangeChannelCommon tId = do- resetEditorState tId- loadLastEdit tId+ -- resetEditorState cId+ -- loadLastEdit tId fetchVisibleIfNeeded tId -loadLastEdit :: TeamId -> MH ()-loadLastEdit tId = do- withCurrentChannel tId $ \cId _ -> do- oldEphemeral <- preuse (csChannel(cId).ccEditState)- case oldEphemeral of- Nothing -> return ()- Just e -> csTeam(tId).tsEditState.cedEphemeral .= e-- loadLastChannelInput tId--loadLastChannelInput :: TeamId -> MH ()-loadLastChannelInput tId = do- withCurrentChannel tId $ \cId _ -> do- inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition)- case inputHistoryPos of- Just i -> loadHistoryEntryToEditor tId cId i- Nothing -> do- (lastEdit, lastEditMode) <- use (csTeam(tId).tsEditState.cedEphemeral.eesLastInput)- csTeam(tId).tsEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper)- csTeam(tId).tsEditState.cedEditMode .= lastEditMode+loadLastChannelInput :: Lens' ChatState (MessageInterface n i) -> MH ()+loadLastChannelInput which = do+ inputHistoryPos <- use (which.miEditor.esEphemeral.eesInputHistoryPosition)+ case inputHistoryPos of+ Just i -> void $ loadHistoryEntryToEditor which i+ Nothing -> do+ (lastEdit, lastEditMode) <- use (which.miEditor.esEphemeral.eesLastInput)+ which.miEditor.esEditor %= (applyEdit $ insertMany lastEdit . clearZipper)+ which.miEditor.esEditMode .= lastEditMode preChangeChannelCommon :: TeamId -> MH () preChangeChannelCommon tId = do withCurrentChannel tId $ \cId _ -> do csTeam(tId).tsRecentChannel .= Just cId- saveCurrentEdit tId -resetEditorState :: TeamId -> MH ()-resetEditorState tId = do- csTeam(tId).tsEditState.cedEditMode .= NewPost- csTeam(tId).tsEditState.cedEditor %= applyEdit clearZipper--saveCurrentEdit :: TeamId -> MH ()-saveCurrentEdit tId = do- withCurrentChannel tId $ \cId _ -> do- saveCurrentChannelInput tId-- oldEphemeral <- use (csTeam(tId).tsEditState.cedEphemeral)- csChannel(cId).ccEditState .= oldEphemeral--saveCurrentChannelInput :: TeamId -> MH ()-saveCurrentChannelInput tId = do- cmdLine <- use (csTeam(tId).tsEditState.cedEditor)- mode <- use (csTeam(tId).tsEditState.cedEditMode)+saveEditorInput :: Lens' ChatState (MessageInterface n i) -> MH ()+saveEditorInput which = do+ cmdLine <- use (which.miEditor.esEditor)+ mode <- use (which.miEditor.esEditMode) -- Only save the editor contents if the user is not navigating the -- history.- inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition)+ inputHistoryPos <- use (which.miEditor.esEphemeral.eesInputHistoryPosition) when (isNothing inputHistoryPos) $- csTeam(tId).tsEditState.cedEphemeral.eesLastInput .=+ which.miEditor.esEphemeral.eesLastInput .= (T.intercalate "\n" $ getEditContents $ cmdLine, mode) applyPreferenceChange :: Preference -> MH ()@@ -680,7 +665,7 @@ -- to scroll the channel list up far enough to show -- the topmost section header. when (entry == (head $ concat $ snd <$> Z.toList z)) $ do- mh $ vScrollToBeginning $ viewportScroll (ChannelList tId)+ mh $ vScrollToBeginning $ viewportScroll (ChannelListViewport tId) setFocusWith tId True Z.right checkForFirst (return ()) @@ -864,45 +849,50 @@ return $ Just $ do forM_ missingUsernames (mhError . NoSuchUser) -channelHistoryForward :: TeamId -> MH ()-channelHistoryForward tId = do- withCurrentChannel tId $ \cId _ -> do- resetAutocomplete tId+inputHistoryForward :: Lens' ChatState (MessageInterface n i) -> MH ()+inputHistoryForward which = do+ resetAutocomplete (which.miEditor) - inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition)- case inputHistoryPos of- Just i- | i == 0 -> do- -- Transition out of history navigation- csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing- loadLastChannelInput tId- | otherwise -> do- let newI = i - 1- loadHistoryEntryToEditor tId cId newI- csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)- _ -> return ()+ inputHistoryPos <- use (which.miEditor.esEphemeral.eesInputHistoryPosition)+ case inputHistoryPos of+ Just i+ | i == 0 -> do+ -- Transition out of history navigation+ which.miEditor.esEphemeral.eesInputHistoryPosition .= Nothing+ loadLastChannelInput which+ | otherwise -> do+ let newI = i - 1+ loaded <- loadHistoryEntryToEditor which newI+ when loaded $+ which.miEditor.esEphemeral.eesInputHistoryPosition .= (Just newI)+ _ -> return () -loadHistoryEntryToEditor :: TeamId -> ChannelId -> Int -> MH ()-loadHistoryEntryToEditor tId cId idx = do+loadHistoryEntryToEditor :: Lens' ChatState (MessageInterface n i) -> Int -> MH Bool+loadHistoryEntryToEditor which idx = do+ cId <- use (which.miChannelId) inputHistory <- use csInputHistory case getHistoryEntry cId idx inputHistory of- Nothing -> return ()+ Nothing -> return False Just entry -> do let eLines = T.lines entry mv = if length eLines == 1 then gotoEOL else id- csTeam(tId).tsEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)+ which.miEditor.esEditor.editContentsL .= (mv $ textZipper eLines Nothing)+ cfg <- use (csResources.crConfiguration)+ when (configShowMessagePreview cfg) $+ invalidateChannelRenderingCache cId+ return True -channelHistoryBackward :: TeamId -> MH ()-channelHistoryBackward tId = do- withCurrentChannel tId $ \cId _ -> do- resetAutocomplete tId+inputHistoryBackward :: Lens' ChatState (MessageInterface n i) -> MH ()+inputHistoryBackward which = do+ resetAutocomplete (which.miEditor) - inputHistoryPos <- use (csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition)- saveCurrentChannelInput tId+ inputHistoryPos <- use (which.miEditor.esEphemeral.eesInputHistoryPosition)+ saveEditorInput which - let newI = maybe 0 (+ 1) inputHistoryPos- loadHistoryEntryToEditor tId cId newI- csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)+ let newI = maybe 0 (+ 1) inputHistoryPos+ loaded <- loadHistoryEntryToEditor which newI+ when loaded $+ which.miEditor.esEphemeral.eesInputHistoryPosition .= (Just newI) createOrdinaryChannel :: TeamId -> Bool -> Text -> MH () createOrdinaryChannel myTId public name = do@@ -970,12 +960,11 @@ case ch^.ccInfo.cdType of Direct -> hideDMChannel (ch^.ccInfo.cdChannelId) Group -> hideDMChannel (ch^.ccInfo.cdChannelId)- _ -> setMode tId LeaveChannelConfirm+ _ -> pushMode tId LeaveChannelConfirm deleteCurrentChannel :: TeamId -> MH () deleteCurrentChannel tId = do withCurrentChannel tId $ \cId _ -> do- setMode tId Main leaveChannelIfPossible cId True isCurrentChannel :: ChatState -> TeamId -> ChannelId -> Bool@@ -1003,7 +992,6 @@ joinChannel' :: TeamId -> ChannelId -> Maybe (MH ()) -> MH () joinChannel' tId chanId act = do- setMode tId Main mChan <- preuse (csChannel(chanId)) case mChan of Just _ -> do@@ -1046,7 +1034,6 @@ if (_uiId <$> foundUser) == Just myId then return () else do- setMode tId Main let err = mhError $ AmbiguousName name case (mCId, mDMCId) of (Nothing, Nothing) ->@@ -1103,7 +1090,7 @@ withCurrentChannel tId $ \_ chan -> do let chType = chan^.ccInfo.cdType if chType /= Direct- then setMode tId DeleteChannelConfirm+ then pushMode tId DeleteChannelConfirm else mhError $ GenericError "Direct message channels cannot be deleted." updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH ()
src/Matterhorn/State/Common.hs view
@@ -17,11 +17,18 @@ , postErrorMessage' , addEmoteFormatting , removeEmoteFormatting+ , toggleMouseMode , fetchMentionedUsers , doPendingUserFetches , doPendingUserStatusFetches + , setThreadOrientationByName++ -- Cache management+ , invalidateChannelRenderingCache+ , invalidateMessageRenderingCacheByPostId+ , module Matterhorn.State.Async ) where@@ -29,7 +36,7 @@ import Prelude () import Matterhorn.Prelude -import Brick.Main ( invalidateCacheEntry )+import Brick.Main ( invalidateCacheEntry, invalidateCache, getVtyHandle ) import Control.Concurrent ( MVar, putMVar, forkIO ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException, try )@@ -38,6 +45,7 @@ import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T+import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( (.=), (%=), (%~), (.~) ) import System.Directory ( createDirectoryIfMissing ) import System.Environment.XDG.BaseDir ( getUserCacheDir )@@ -130,11 +138,11 @@ withCurrentTeam $ \tId -> do withCurrentChannel tId $ \cid _ -> do uuid <- generateUUID- let addCMsg = ccContents.cdMessages %~+ let addCMsg = ccMessageInterface.miMessages %~ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) csChannels %= modifyChannelById cid addCMsg - mh $ invalidateCacheEntry $ ChannelMessages cid+ invalidateChannelRenderingCache cid mh $ invalidateCacheEntry $ ChannelSidebar tId let msgTy = case msg^.cmType of@@ -165,7 +173,7 @@ Just cId -> do msg <- newClientMessage Error err uuid <- generateUUID_IO- let addEMsg = ccContents.cdMessages %~+ let addEMsg = ccMessageInterface.miMessages %~ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) return $ st & csChannels %~ modifyChannelById cId addEMsg @@ -206,7 +214,7 @@ -- current channel will be displayed as new. withCurrentTeam $ \tId -> do withCurrentChannel tId $ \cId curChan -> do- let msgs = curChan^.ccContents.cdMessages+ let msgs = curChan^.ccMessageInterface.miMessages case findLatestUserMessage isEditable msgs of Nothing -> return () Just m ->@@ -241,7 +249,7 @@ return $ case st^.csCurrentTeamId of Nothing -> st- Just tId -> setMode' tId Main st+ Just tId -> pushMode' tId Main st runInteractiveCommand :: String -> [String]@@ -408,3 +416,41 @@ forM_ results (\u -> addNewUser $ userInfoFromUser u True) return $ Just $ act1 >> act2++invalidateChannelRenderingCache :: ChannelId -> MH ()+invalidateChannelRenderingCache cId = do+ mh $ invalidateCacheEntry $ MessageInterfaceMessages $ MessageInput cId+ mh $ invalidateCacheEntry $ MessageInterfaceMessages $ ThreadMessageInput cId++invalidateMessageRenderingCacheByPostId :: PostId -> MH ()+invalidateMessageRenderingCacheByPostId pId = do+ mh $ invalidateCacheEntry $ RenderedMessage $ MessagePostId pId++setThreadOrientationByName :: T.Text -> MH ()+setThreadOrientationByName o = do+ let o' = T.strip $ T.toLower o+ new <- case o' of+ "above" -> return $ Just ThreadAbove+ "below" -> return $ Just ThreadBelow+ "left" -> return $ Just ThreadLeft+ "right" -> return $ Just ThreadRight+ _ -> do+ postErrorMessage' $ T.pack $ "Invalid orientation: " <> show o+ return Nothing++ case new of+ Nothing -> return ()+ Just n -> do+ csResources.crConfiguration.configThreadOrientationL .= n+ postInfoMessage $ "Thread orientation set to " <> o'+ mh invalidateCache++toggleMouseMode :: MH ()+toggleMouseMode = do+ vty <- mh getVtyHandle+ csResources.crConfiguration.configMouseModeL %= not+ newMode <- use (csResources.crConfiguration.configMouseModeL)+ liftIO $ Vty.setMode (Vty.outputIface vty) Vty.Mouse newMode+ postInfoMessage $ if newMode+ then "Mouse input is now enabled."+ else "Mouse input is now disabled."
src/Matterhorn/State/Editing.hs view
@@ -5,7 +5,6 @@ ( requestSpellCheck , editingKeybindings , editingKeyHandlers- , messageEditingKeybindings , toggleMultilineEditing , invokeExternalEditor , handlePaste@@ -22,7 +21,7 @@ import Prelude () import Matterhorn.Prelude -import Brick.Main ( invalidateCache, invalidateCacheEntry )+import Brick.Main ( invalidateCache ) import Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent , getEditContents, editContentsL ) import qualified Brick.Widgets.List as L@@ -32,7 +31,6 @@ import qualified Data.ByteString as BS import Data.Char ( isSpace ) import qualified Data.Foldable as F-import qualified Data.Map as M import Data.Maybe ( fromJust ) import qualified Data.Set as S import qualified Data.Text as T@@ -41,15 +39,15 @@ import qualified Data.Text.Zipper.Generic.Words as Z import Data.Time ( getCurrentTime ) import Graphics.Vty ( Event(..), Key(..) )-import Lens.Micro.Platform ( Lens', (%=), (.=), (.~), to, _Just )+import Lens.Micro.Platform ( Traversal', Lens', (%=), (.=), (.~), to, _Just ) import qualified System.Environment as Sys import qualified System.Exit as Sys import qualified System.IO as Sys import qualified System.IO.Temp as Sys import qualified System.Process as Sys-import Text.Aspell ( AspellResponse(..), mistakeWord, askAspell )+import Text.Aspell ( Aspell, AspellResponse(..), mistakeWord, askAspell ) -import Network.Mattermost.Types ( Post(..), ChannelId, TeamId )+import Network.Mattermost.Types ( Post(..) ) import Matterhorn.Config import {-# SOURCE #-} Matterhorn.Command ( dispatchCommand )@@ -57,33 +55,33 @@ import Matterhorn.Events.Keybindings import Matterhorn.State.Common import Matterhorn.State.Autocomplete-import Matterhorn.State.Attachments-import Matterhorn.State.Messages+import {-# SOURCE #-} Matterhorn.State.Messages+import {-# SOURCE #-} Matterhorn.State.ThreadWindow import Matterhorn.Types hiding ( newState ) import Matterhorn.Types.Common ( sanitizeUserText' ) -startMultilineEditing :: TeamId -> MH ()-startMultilineEditing tId = do+startMultilineEditing :: Lens' ChatState (EditState Name) -> MH ()+startMultilineEditing which = do mh invalidateCache- csTeam(tId).tsEditState.cedEphemeral.eesMultiline .= True+ which.esEphemeral.eesMultiline .= True -toggleMultilineEditing :: TeamId -> MH ()-toggleMultilineEditing tId = do+toggleMultilineEditing :: Lens' ChatState (EditState Name) -> MH ()+toggleMultilineEditing which = do mh invalidateCache- csTeam(tId).tsEditState.cedEphemeral.eesMultiline %= not+ which.esEphemeral.eesMultiline %= not -- If multiline is now disabled and there is more than one line in -- the editor, that means we're showing the multiline message status -- (see Draw.Main.renderUserCommandBox.commandBox) so we want to be -- sure no autocomplete UI is present in case the cursor was left on -- a word that would otherwise show completion alternatives.- multiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline)- numLines <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents.to length)- when (not multiline && numLines > 1) (resetAutocomplete tId)+ multiline <- use (which.esEphemeral.eesMultiline)+ numLines <- use (which.esEditor.to getEditContents.to length)+ when (not multiline && numLines > 1) (resetAutocomplete which) -invokeExternalEditor :: TeamId -> MH ()-invokeExternalEditor tId = do+invokeExternalEditor :: Lens' ChatState (EditState Name) -> MH ()+invokeExternalEditor which = do -- If EDITOR is in the environment, write the current message to a -- temp file, invoke EDITOR on it, read the result, remove the temp -- file, and update the program state.@@ -96,7 +94,7 @@ Sys.withSystemTempFile "matterhorn_editor.md" $ \tmpFileName tmpFileHandle -> do -- Write the current message to the temp file Sys.hPutStr tmpFileHandle $ T.unpack $ T.intercalate "\n" $- getEditContents $ st^.csTeam(tId).tsEditState.cedEditor+ getEditContents $ st^.which.esEditor Sys.hClose tmpFileHandle -- Run the editor@@ -112,42 +110,28 @@ postErrorMessageIO "Failed to decode file contents as UTF-8" st Right t -> do let tmpLines = T.lines $ sanitizeUserText' t- return $ st & csTeam(tId).tsEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing)+ return $ st & which.esEditor.editContentsL .~ (Z.textZipper tmpLines Nothing) Sys.ExitFailure _ -> return st -handlePaste :: TeamId -> BS.ByteString -> MH ()-handlePaste tId bytes = do+handlePaste :: Lens' ChatState (EditState Name) -> BS.ByteString -> MH ()+handlePaste which bytes = do let pasteStr = T.pack (UTF8.toString bytes)- csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr))- contents <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents)+ which.esEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr))+ contents <- use (which.esEditor.to getEditContents) case length contents > 1 of- True -> startMultilineEditing tId+ True -> startMultilineEditing which False -> return () -editingPermitted :: ChatState -> TeamId -> Bool-editingPermitted st tId =- (length (getEditContents $ st^.csTeam(tId).tsEditState.cedEditor) == 1) ||- st^.csTeam(tId).tsEditState.cedEphemeral.eesMultiline--messageEditingKeybindings :: TeamId -> KeyConfig -> KeyHandlerMap-messageEditingKeybindings tId kc =- let KeyHandlerMap m = editingKeybindings tId (csTeam(tId).tsEditState.cedEditor) kc- in KeyHandlerMap $ M.map (withUserTypingAction tId) m--withUserTypingAction :: TeamId -> KeyHandler -> KeyHandler-withUserTypingAction tId kh =- kh { khHandler = newH }- where- oldH = khHandler kh- newH = oldH { kehHandler = newKEH }- oldKEH = kehHandler oldH- newKEH = oldKEH { ehAction = ehAction oldKEH >> sendUserTypingAction tId }+editingPermitted :: ChatState -> Lens' ChatState (EditState Name) -> Bool+editingPermitted st which =+ (length (getEditContents $ st^.which.esEditor) == 1) ||+ st^.which.esEphemeral.eesMultiline -editingKeybindings :: TeamId -> Lens' ChatState (Editor T.Text Name) -> KeyConfig -> KeyHandlerMap-editingKeybindings tId editor = mkKeybindings $ editingKeyHandlers tId editor+editingKeybindings :: Lens' ChatState (Editor T.Text Name) -> KeyConfig -> KeyHandlerMap+editingKeybindings editor = mkKeybindings $ editingKeyHandlers editor -editingKeyHandlers :: TeamId -> Lens' ChatState (Editor T.Text Name) -> [KeyEventHandler]-editingKeyHandlers tId editor =+editingKeyHandlers :: Lens' ChatState (Editor T.Text Name) -> [KeyEventHandler]+editingKeyHandlers editor = [ mkKb EditorTransposeCharsEvent "Transpose the final two characters" (editor %= applyEdit Z.transposeChars)@@ -163,12 +147,6 @@ , mkKb EditorKillToBolEvent "Delete from the cursor to the start of the current line" (editor %= applyEdit Z.killToBOL)- , mkKb EditorKillToEolEvent- "Kill the line to the right of the current position and copy it" $ do- z <- use (editor.editContentsL)- let restOfLine = Z.currentLine (Z.killToBOL z)- csTeam(tId).tsEditState.cedYankBuffer .= restOfLine- editor %= applyEdit Z.killToEOL , mkKb EditorNextCharEvent "Move one character to the right" (editor %= applyEdit Z.moveRight)@@ -193,15 +171,21 @@ , mkKb EditorEndEvent "Move the cursor to the end of the input" $ do editor %= applyEdit gotoEnd+ , mkKb EditorKillToEolEvent+ "Kill the line to the right of the current position and copy it" $ do+ z <- use (editor.editContentsL)+ let restOfLine = Z.currentLine (Z.killToBOL z)+ csGlobalEditState.gedYankBuffer .= restOfLine+ editor %= applyEdit Z.killToEOL , mkKb EditorYankEvent "Paste the current buffer contents at the cursor" $ do- buf <- use (csTeam(tId).tsEditState.cedYankBuffer)- editor %= applyEdit (Z.insertMany buf)+ buf <- use (csGlobalEditState.gedYankBuffer)+ editor %= applyEdit (Z.insertMany buf) ] -getEditorContent :: TeamId -> MH Text-getEditorContent tId = do- cmdLine <- use (csTeam(tId).tsEditState.cedEditor)+getEditorContent :: Lens' ChatState (EditState Name) -> MH Text+getEditorContent which = do+ cmdLine <- use (which.esEditor) let (line, rest) = case getEditContents cmdLine of (a:as) -> (a, as) _ -> error "BUG: getEditorContent: got empty edit contents"@@ -218,35 +202,44 @@ -- *source* of the text, so it also takes care of clearing the editor, -- resetting the edit mode, updating the input history for the specified -- channel, etc.-handleInputSubmission :: TeamId -> ChannelId -> Text -> MH ()-handleInputSubmission tId cId content = do+handleInputSubmission :: Lens' ChatState (EditState Name)+ -> Text+ -> MH ()+handleInputSubmission editWhich content = do+ cId <- use (editWhich.esChannelId)+ -- We clean up before dispatching the command or sending the message -- since otherwise the command could change the state and then doing -- cleanup afterwards could clean up the wrong things.- csTeam(tId).tsEditState.cedEditor %= applyEdit Z.clearZipper- csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing+ editWhich.esEditor %= applyEdit Z.clearZipper+ editWhich.esEphemeral.eesInputHistoryPosition .= Nothing csInputHistory %= addHistoryEntry content cId case T.uncons content of- Just ('/', cmd) ->+ Just ('/', cmd) -> do+ tId <- do+ mTid <- use (editWhich.esTeamId)+ Just curTid <- use csCurrentTeamId+ return $ fromMaybe curTid mTid dispatchCommand tId cmd _ -> do- attachments <- use (csTeam(tId).tsEditState.cedAttachmentList.L.listElementsL)- mode <- use (csTeam(tId).tsEditState.cedEditMode)+ attachments <- use (editWhich.esAttachmentList.L.listElementsL)+ mode <- use (editWhich.esEditMode) sendMessage cId mode content $ F.toList attachments - -- Empty the attachment list only if a mesage is actually sent, since- -- it's possible to /attach a file before actually sending the- -- message- resetAttachmentList tId+ -- Empty the attachment list only if a mesage is+ -- actually sent, since it's possible to /attach a+ -- file before actually sending the message+ resetAttachmentList editWhich -- Reset the autocomplete UI- resetAutocomplete tId+ resetAutocomplete editWhich -- Reset the edit mode *after* handling the input so that the input -- handler can tell whether we're editing, replying, etc.- csTeam(tId).tsEditState.cedEditMode .= NewPost+ resetEditMode <- use (editWhich.esResetEditMode)+ editWhich.esEditMode .= resetEditMode closingPunctuationMarks :: String closingPunctuationMarks = ".,'\";:)]!?"@@ -255,8 +248,12 @@ isSmartClosingPunctuation (EvKey (KChar c) []) = c `elem` closingPunctuationMarks isSmartClosingPunctuation _ = False -handleEditingInput :: TeamId -> Event -> MH ()-handleEditingInput tId e = do+handleEditingInput :: Lens' ChatState (EditState Name)+ -> Event+ -> MH ()+handleEditingInput which e = do+ cId <- use (which.esChannelId)+ -- Only handle input events to the editor if we permit editing: -- if multiline mode is off, or if there is only one line of text -- in the editor. This means we skip input this catch-all handler@@ -267,141 +264,156 @@ -- Record the input line count before handling the editing event -- so we can tell whether the editing event changes the line count -- later.- beforeLineCount <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents.to length)+ beforeLineCount <- use (which.esEditor.to getEditContents.to length) smartBacktick <- use (csResources.crConfiguration.configSmartBacktickL) let smartChars = "*`_" st <- use id- csTeam(tId).tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing+ which.esEphemeral.eesInputHistoryPosition .= Nothing smartEditing <- use (csResources.crConfiguration.configSmartEditingL)- justCompleted <- use (csTeam(tId).tsEditState.cedJustCompleted)+ justCompleted <- use (which.esJustCompleted) conf <- use (csResources.crConfiguration)- let keyMap = editingKeybindings tId (csTeam(tId).tsEditState.cedEditor) (configUserKeys conf)+ let keyMap = editingKeybindings (which.esEditor) (configUserKeys conf) case lookupKeybinding e keyMap of- Just kb | editingPermitted st tId -> (ehAction $ kehHandler $ khHandler kb)+ Just kb | editingPermitted st which -> (ehAction $ kehHandler $ khHandler kb) _ -> do case e of -- Not editing; backspace here means cancel multi-line message -- composition- EvKey KBS [] | (not $ editingPermitted st tId) -> do- csTeam(tId).tsEditState.cedEditor %= applyEdit Z.clearZipper+ EvKey KBS [] | (not $ editingPermitted st which) -> do+ which.esEditor %= applyEdit Z.clearZipper mh invalidateCache -- Backspace in editing mode with smart pair insertion means -- smart pair removal when possible- EvKey KBS [] | editingPermitted st tId && smartBacktick ->- let backspace = csTeam(tId).tsEditState.cedEditor %= applyEdit Z.deletePrevChar- in case cursorAtOneOf smartChars (st^.csTeam(tId).tsEditState.cedEditor) of+ EvKey KBS [] | editingPermitted st which && smartBacktick ->+ let backspace = which.esEditor %= applyEdit Z.deletePrevChar+ in case cursorAtOneOf smartChars (st^.which.esEditor) of Nothing -> backspace Just ch -> -- Smart char removal:- if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csTeam(tId).tsEditState.cedEditor) &&- (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csTeam(tId).tsEditState.cedEditor) ->- csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar)+ if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.which.esEditor) &&+ (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.which.esEditor) ->+ which.esEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar) | otherwise -> backspace EvKey (KChar ch) []- | editingPermitted st tId && smartBacktick && ch `elem` smartChars ->+ | editingPermitted st which && smartBacktick && ch `elem` smartChars -> -- Smart char insertion: let doInsertChar = do- csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertChar ch)- sendUserTypingAction tId- curLine = Z.currentLine $ st^.csTeam(tId).tsEditState.cedEditor.editContentsL+ which.esEditor %= applyEdit (Z.insertChar ch)+ sendUserTypingAction which+ curLine = Z.currentLine $ st^.which.esEditor.editContentsL -- First case: if the cursor is at the end of the current -- line and it contains "``" and the user entered a third -- "`", enable multi-line mode since they're likely typing -- a code block.- in if | (cursorIsAtEnd $ st^.csTeam(tId).tsEditState.cedEditor) &&+ in if | (cursorIsAtEnd $ st^.which.esEditor) && curLine == "``" && ch == '`' -> do- csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch))- csTeam(tId).tsEditState.cedEphemeral.eesMultiline .= True+ which.esEditor %= applyEdit (Z.insertMany (T.singleton ch))+ which.esEphemeral.eesMultiline .= True -- Second case: user entered some smart character -- (don't care which) on an empty line or at the end -- of the line after whitespace, so enter a pair of -- the smart chars and put the cursor between them.- | (editorEmpty $ st^.csTeam(tId).tsEditState.cedEditor) ||- ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csTeam(tId).tsEditState.cedEditor)) &&- (cursorIsAtEnd $ st^.csTeam(tId).tsEditState.cedEditor)) ->- csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft)+ | (editorEmpty $ st^.which.esEditor) ||+ ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.which.esEditor)) &&+ (cursorIsAtEnd $ st^.which.esEditor)) ->+ which.esEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft) -- Third case: the cursor is already on a smart -- character and that character is the last one -- on the line, so instead of inserting a new -- character, just move past it.- | (cursorAtChar ch $ st^.csTeam(tId).tsEditState.cedEditor) &&- (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csTeam(tId).tsEditState.cedEditor) ->- csTeam(tId).tsEditState.cedEditor %= applyEdit Z.moveRight+ | (cursorAtChar ch $ st^.which.esEditor) &&+ (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.which.esEditor) ->+ which.esEditor %= applyEdit Z.moveRight -- Fall-through case: just insert one of the chars -- without doing anything smart. | otherwise -> doInsertChar- | editingPermitted st tId -> do+ | editingPermitted st which -> do -- If the most recent editing event was a tab completion, -- there is a trailing space that we want to remove if the -- next input character is punctuation. when (smartEditing && justCompleted && isSmartClosingPunctuation e) $- csTeam(tId).tsEditState.cedEditor %= applyEdit Z.deletePrevChar+ which.esEditor %= applyEdit Z.deletePrevChar - csTeam(tId).tsEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' $ T.singleton ch))- sendUserTypingAction tId- _ | editingPermitted st tId -> do- mhHandleEventLensed (csTeam(tId).tsEditState.cedEditor) handleEditorEvent e- sendUserTypingAction tId+ which.esEditor %= applyEdit (Z.insertMany (sanitizeUserText' $ T.singleton ch))+ sendUserTypingAction which+ _ | editingPermitted st which -> do+ mhHandleEventLensed (which.esEditor) handleEditorEvent e+ sendUserTypingAction which | otherwise -> return () let ctx = AutocompleteContext { autocompleteManual = False , autocompleteFirstMatch = False }- checkForAutocompletion tId ctx- liftIO $ resetSpellCheckTimer $ st^.csTeam(tId).tsEditState+ checkForAutocompletion which ctx + -- Reset the spell check timer for this editor+ mReset <- use (which.esSpellCheckTimerReset)+ case mReset of+ Nothing -> return ()+ Just reset -> liftIO reset+ -- If the preview is enabled and multi-line editing is enabled and -- the line count changed, we need to invalidate the rendering cache -- entry for the channel messages because we want to redraw them to -- fit in the space just changed by the size of the preview area.- afterLineCount <- use (csTeam(tId).tsEditState.cedEditor.to getEditContents.to length)- isMultiline <- use (csTeam(tId).tsEditState.cedEphemeral.eesMultiline)+ afterLineCount <- use (which.esEditor.to getEditContents.to length)+ isMultiline <- use (which.esEphemeral.eesMultiline) isPreviewing <- use (csResources.crConfiguration.configShowMessagePreviewL) when (beforeLineCount /= afterLineCount && isMultiline && isPreviewing) $ do- withCurrentChannel tId $ \cId _ -> do- mh $ invalidateCacheEntry $ ChannelMessages cId+ invalidateChannelRenderingCache cId -- Reset the recent autocompletion flag to stop smart punctuation -- handling. when justCompleted $- csTeam(tId).tsEditState.cedJustCompleted .= False+ which.esJustCompleted .= False -- | Send the user_typing action to the server asynchronously, over the -- connected websocket. If the websocket is not connected, drop the -- action silently.-sendUserTypingAction :: TeamId -> MH ()-sendUserTypingAction tId = do- withCurrentChannel tId $ \cId _ -> do- st <- use id- when (configSendTypingNotifications (st^.csResources.crConfiguration)) $- case st^.csConnectionStatus of- Connected -> do- let pId = case st^.csTeam(tId).tsEditState.cedEditMode of- Replying _ post -> Just $ postId post- _ -> Nothing- liftIO $ do- now <- getCurrentTime- let action = UserTyping now cId pId- STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action- Disconnected -> return ()+sendUserTypingAction :: Lens' ChatState (EditState Name)+ -> MH ()+sendUserTypingAction which = do+ st <- use id+ when (configSendTypingNotifications (st^.csResources.crConfiguration)) $+ case st^.csConnectionStatus of+ Connected -> do+ let pId = case st^.which.esEditMode of+ Replying _ post -> Just $ postId post+ _ -> Nothing+ cId <- use (which.esChannelId)+ liftIO $ do+ now <- getCurrentTime+ let action = UserTyping now cId pId+ STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action+ Disconnected -> return () -- Kick off an async request to the spell checker for the current editor -- contents.-requestSpellCheck :: TeamId -> MH ()-requestSpellCheck tId = do- st <- use id- case st^.csTeam(tId).tsEditState.cedSpellChecker of+requestSpellCheck :: Aspell -> MessageInterfaceTarget -> MH ()+requestSpellCheck checker target = do+ -- Get the editor contents.+ mContents <- case target of+ MITeamThread tId -> do+ mTi <- use (maybeThreadInterface(tId))+ case mTi of+ Nothing -> return Nothing+ Just ti -> return $ Just $ getEditContents $ ti^.miEditor.esEditor+ MIChannel cId -> do+ mMi <- preuse (maybeChannelMessageInterface(cId))+ case mMi of+ Nothing -> return Nothing+ Just mi -> return $ Just $ getEditContents $ mi^.miEditor.esEditor++ case mContents of Nothing -> return ()- Just (checker, _) -> do- -- Get the editor contents.- contents <- getEditContents <$> use (csTeam(tId).tsEditState.cedEditor)+ Just contents -> doAsyncWith Preempt $ do -- For each line in the editor, submit an aspell request. let query = concat <$> mapM (askAspell checker) contents@@ -410,8 +422,13 @@ let getMistakes AllCorrect = [] getMistakes (Mistakes ms) = mistakeWord <$> ms allMistakes = S.fromList $ concat $ getMistakes <$> responses- csTeam(tId).tsEditState.cedMisspellings .= allMistakes + case target of+ MITeamThread tId ->+ maybeThreadInterface(tId)._Just.miEditor.esMisspellings .= allMistakes+ MIChannel cId ->+ maybeChannelMessageInterface(cId).miEditor.esMisspellings .= allMistakes+ tryMM query (return . Just . postMistakes) editorEmpty :: Editor Text a -> Bool@@ -457,39 +474,59 @@ then Z.moveCursor (numLines - 1, lastLineLength) z else z -cancelAutocompleteOrReplyOrEdit :: TeamId -> MH ()-cancelAutocompleteOrReplyOrEdit tId = do- withCurrentChannel tId $ \cId _ -> do- mh $ invalidateCacheEntry $ ChannelMessages cId- ac <- use (csTeam(tId).tsEditState.cedAutocomplete)- case ac of- Just _ -> do- resetAutocomplete tId- Nothing -> do- mode <- use (csTeam(tId).tsEditState.cedEditMode)- case mode of- NewPost -> return ()- _ -> do- csTeam(tId).tsEditState.cedEditMode .= NewPost- csTeam(tId).tsEditState.cedEditor %= applyEdit Z.clearZipper- resetAttachmentList tId+-- Cancels the following states in this order, as appropriate based on+-- context:+-- * Autocomplete UI display+-- * Reply+-- * Edit+-- * Close current team's thread window if open+cancelAutocompleteOrReplyOrEdit :: Lens' ChatState (EditState Name) -> MH ()+cancelAutocompleteOrReplyOrEdit which = do+ cId <- use (which.esChannelId)+ invalidateChannelRenderingCache cId+ ac <- use (which.esAutocomplete)+ case ac of+ Just _ -> do+ resetAutocomplete which+ Nothing -> do+ resetEditMode <- use (which.esResetEditMode) -replyToLatestMessage :: TeamId -> MH ()-replyToLatestMessage tId = do- withCurrentChannel tId $ \cId chan -> do- let msgs = chan^. ccContents . cdMessages+ let resetEditor = do+ which.esEditMode .= resetEditMode+ which.esEditor %= applyEdit Z.clearZipper+ resetAttachmentList which++ curEditMode <- use (which.esEditMode)+ case curEditMode of+ NewPost -> return ()+ Editing {} -> resetEditor+ Replying {} -> do+ prevMode <- use (which.esEditMode)+ resetEditor+ newMode <- use (which.esEditMode)+ when (newMode == prevMode) $+ withCurrentTeam $ \tId -> do+ ti <- use (csTeam(tId).tsThreadInterface)+ foc <- use (csTeam(tId).tsMessageInterfaceFocus)+ when (isJust ti && foc == FocusThread) $+ closeThreadWindow tId++replyToLatestMessage :: Lens' ChatState (EditState Name) -> MH ()+replyToLatestMessage which = do+ cId <- use (which.esChannelId)+ withChannel cId $ \chan -> do+ let msgs = chan^.ccMessageInterface.miMessages case findLatestUserMessage isReplyable msgs of Just msg | isReplyable msg -> do rootMsg <- getReplyRootMessage msg- setMode tId Main- mh $ invalidateCacheEntry $ ChannelMessages cId- csTeam(tId).tsEditState.cedEditMode .= Replying rootMsg (fromJust $ rootMsg^.mOriginalPost)+ invalidateChannelRenderingCache cId+ which.esEditMode .= Replying rootMsg (fromJust $ rootMsg^.mOriginalPost) _ -> return () data Direction = Forwards | Backwards -tabComplete :: TeamId -> Direction -> MH ()-tabComplete tId dir = do+tabComplete :: Traversal' ChatState (EditState Name) -> Direction -> MH ()+tabComplete which dir = do let transform list = let len = list^.L.listElementsL.to length in case dir of@@ -503,15 +540,16 @@ (L.listSelected list == Nothing && len > 0) then L.listMoveTo (len - 1) list else L.listMoveBy (-1) list- csTeam(tId).tsEditState.cedAutocomplete._Just.acCompletionList %= transform - mac <- use (csTeam(tId).tsEditState.cedAutocomplete)+ which.esAutocomplete._Just.acCompletionList %= transform++ mac <- join <$> preuse (which.esAutocomplete) case mac of Nothing -> do let ctx = AutocompleteContext { autocompleteManual = True , autocompleteFirstMatch = True }- checkForAutocompletion tId ctx+ checkForAutocompletion which ctx Just ac -> do case ac^.acCompletionList.to L.listSelectedElement of Nothing -> return ()@@ -521,12 +559,16 @@ if maybe True isSpace (Z.currentChar z) then z else Z.moveWordRight z- csTeam(tId).tsEditState.cedEditor %=+ which.esEditor %= applyEdit (Z.insertChar ' ' . Z.insertMany replacement . Z.deletePrevWord . maybeEndOfWord)- csTeam(tId).tsEditState.cedJustCompleted .= True+ which.esJustCompleted .= True -- If there was only one completion alternative, -- hide the autocomplete listing now that we've -- completed the only completion.- when (ac^.acCompletionList.to L.listElements.to length == 1) (resetAutocomplete tId)+ when (ac^.acCompletionList.to L.listElements.to length == 1) (resetAutocomplete which)++resetAttachmentList :: Lens' ChatState (EditState Name) -> MH ()+resetAttachmentList which = do+ which.esAttachmentList %= L.listClear
src/Matterhorn/State/Editing.hs-boot view
@@ -1,11 +1,12 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.Editing ( Direction(..) , tabComplete ) where -import Network.Mattermost.Types ( TeamId )-import Matterhorn.Types ( MH )+import Matterhorn.Types ( MH, ChatState, EditState, Name )+import Lens.Micro.Platform ( Traversal' ) data Direction = Forwards | Backwards-tabComplete :: TeamId -> Direction -> MH ()+tabComplete :: Traversal' ChatState (EditState Name) -> Direction -> MH ()
src/Matterhorn/State/Flagging.hs view
@@ -41,19 +41,30 @@ Just msg | Just cId <- msg^.mChannelId -> withChannel cId $ \chan -> do let isTargetMessage m = m^.mMessageId == Just (MessagePostId pId)- csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f+ csChannelMessages(cId).traversed.filtered isTargetMessage.mFlagged .= f csPostMap.ix(pId).mFlagged .= f + invalidateChannelRenderingCache cId+ invalidateMessageRenderingCacheByPostId pId+ let mTId = chan^.ccInfo.cdTeamId- updatePostOverlay :: TeamId -> MH ()- updatePostOverlay tId = do- -- We also want to update the post overlay if this happens+ updateTeam :: TeamId -> MH ()+ updateTeam tId = do+ -- Update the thread window for this team, if its channel+ -- is the one that the post is in.+ mTi <- preuse (threadInterface(tId))+ case mTi of+ Just ti | ti^.miChannelId == cId ->+ threadInterface(tId).miMessages.traversed.filtered isTargetMessage.mFlagged .= f+ _ -> return ()++ -- We also want to update the post window if this happens -- while we're we're observing it- mode <- use (csTeam tId.tsMode)+ mode <- getTeamMode tId case mode of- PostListOverlay PostListFlagged+ PostListWindow PostListFlagged | f ->- csTeam tId.tsPostListOverlay.postListPosts %=+ csTeam tId.tsPostListWindow.postListPosts %= addMessage (msg & mFlagged .~ True) -- deleting here is tricky, because it means that we@@ -61,20 +72,20 @@ -- it _up_ unless we can't, in which case we'll try -- moving it down. | otherwise -> do- selId <- use (csTeam tId.tsPostListOverlay.postListSelected)- posts <- use (csTeam tId.tsPostListOverlay.postListPosts)+ selId <- use (csTeam tId.tsPostListWindow.postListSelected)+ posts <- use (csTeam tId.tsPostListWindow.postListPosts) let nextId = case getNextPostId selId posts of Nothing -> getPrevPostId selId posts Just x -> Just x- csTeam tId.tsPostListOverlay.postListSelected .= nextId- csTeam tId.tsPostListOverlay.postListPosts %=+ csTeam tId.tsPostListWindow.postListSelected .= nextId+ csTeam tId.tsPostListWindow.postListPosts %= filterMessages (((/=) `on` _mMessageId) msg) _ -> return () case mTId of Nothing -> do ts <- use csTeams- forM_ (HM.keys ts) updatePostOverlay- Just tId -> updatePostOverlay tId+ forM_ (HM.keys ts) updateTeam+ Just tId -> updateTeam tId _ -> return ()
src/Matterhorn/State/Help.hs view
@@ -15,9 +15,9 @@ showHelpScreen :: TeamId -> HelpTopic -> MH () showHelpScreen tId topic = do- curMode <- use (csTeam(tId).tsMode)+ curMode <- getTeamMode tId case curMode of ShowHelp {} -> return () _ -> do mh $ vScrollToBeginning (viewportScroll HelpViewport)- setMode tId $ ShowHelp topic curMode+ pushMode tId $ ShowHelp topic
src/Matterhorn/State/Links.hs view
@@ -13,7 +13,7 @@ import Network.Mattermost.Types import Matterhorn.State.Common-import Matterhorn.State.Messages ( jumpToPost )+import {-# SOURCE #-} Matterhorn.State.Messages ( jumpToPost ) import Matterhorn.Types import Matterhorn.Types.RichText ( unURL )
− src/Matterhorn/State/ListOverlay.hs
@@ -1,154 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Matterhorn.State.ListOverlay- ( listOverlayActivateCurrent- , listOverlayActivate- , listOverlaySearchString- , listOverlayMove- , exitListOverlay- , enterListOverlayMode- , resetListOverlaySearch- , onEventListOverlay- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Brick.Widgets.List as L-import qualified Brick.Widgets.Edit as E-import qualified Data.Text.Zipper as Z-import qualified Data.Vector as Vec-import Lens.Micro.Platform ( Lens', (%=), (.=) )-import Network.Mattermost.Types ( Session, TeamId )-import qualified Graphics.Vty as Vty--import Matterhorn.Types-import Matterhorn.State.Common-import Matterhorn.State.Editing ( editingKeybindings )-import Matterhorn.Events.Keybindings ( KeyConfig, KeyHandlerMap, handleKeyboardEvent )----- | Activate the specified list overlay's selected item by invoking the--- overlay's configured enter keypress handler function.-listOverlayActivateCurrent :: TeamId -> Lens' ChatState (ListOverlayState a b) -> MH ()-listOverlayActivateCurrent tId which = do- mItem <- L.listSelectedElement <$> use (which.listOverlaySearchResults)- case mItem of- Nothing -> return ()- Just (_, val) -> listOverlayActivate tId which val---- | Activate the specified list overlay's selected item by invoking the--- overlay's configured enter keypress handler function.-listOverlayActivate :: TeamId -> Lens' ChatState (ListOverlayState a b) -> a -> MH ()-listOverlayActivate tId which val = do- handler <- use (which.listOverlayEnterHandler)- activated <- handler val- if activated- then setMode tId Main- else return ()---- | Get the current search string for the specified overlay.-listOverlaySearchString :: Lens' ChatState (ListOverlayState a b) -> MH Text-listOverlaySearchString which =- (head . E.getEditContents) <$> use (which.listOverlaySearchInput)---- | Move the list cursor in the specified overlay.-listOverlayMove :: Lens' ChatState (ListOverlayState a b)- -- ^ Which overlay- -> (L.List Name a -> L.List Name a)- -- ^ How to transform the list in the overlay- -> MH ()-listOverlayMove which how = which.listOverlaySearchResults %= how---- | Clear the state of the specified list overlay and return to the--- Main mode.-exitListOverlay :: TeamId- -> Lens' ChatState (ListOverlayState a b)- -- ^ Which overlay to reset- -> MH ()-exitListOverlay tId which = do- st <- use which- newList <- use (which.listOverlayNewList)- which.listOverlaySearchResults .= newList mempty- which.listOverlayEnterHandler .= (const $ return False)- setMode tId (st^.listOverlayReturnMode)---- | Initialize a list overlay with the specified arguments and switch--- to the specified mode.-enterListOverlayMode :: TeamId- -> (Lens' ChatState (ListOverlayState a b))- -- ^ Which overlay to initialize- -> Mode- -- ^ The mode to change to- -> b- -- ^ The overlay's initial search scope- -> (a -> MH Bool)- -- ^ The overlay's enter keypress handler- -> (b -> Session -> Text -> IO (Vec.Vector a))- -- ^ The overlay's results fetcher function- -> MH ()-enterListOverlayMode tId which mode scope enterHandler fetcher = do- which.listOverlaySearchScope .= scope- which.listOverlaySearchInput.E.editContentsL %= Z.clearZipper- which.listOverlayEnterHandler .= enterHandler- which.listOverlayFetchResults .= fetcher- which.listOverlaySearching .= False- newList <- use (which.listOverlayNewList)- which.listOverlaySearchResults .= newList mempty- setMode tId mode- resetListOverlaySearch which---- | Reset the overlay's search by initiating a new search request for--- the string that is currently in the overlay's editor. This does--- nothing if a search for this overlay is already in progress.-resetListOverlaySearch :: Lens' ChatState (ListOverlayState a b) -> MH ()-resetListOverlaySearch which = do- searchPending <- use (which.listOverlaySearching)-- when (not searchPending) $ do- searchString <- listOverlaySearchString which- which.listOverlaySearching .= True- newList <- use (which.listOverlayNewList)- session <- getSession- scope <- use (which.listOverlaySearchScope)- fetcher <- use (which.listOverlayFetchResults)- doAsyncWith Preempt $ do- results <- fetcher scope session searchString- return $ Just $ do- which.listOverlaySearchResults .= newList results- which.listOverlaySearching .= False-- -- Now that the results are available, check to see if the- -- search string changed since this request was submitted.- -- If so, issue another search.- afterSearchString <- listOverlaySearchString which- when (searchString /= afterSearchString) $ resetListOverlaySearch which---- | Generically handle an event for the list overlay state targeted--- by the specified lens. Automatically dispatches new searches in the--- overlay's editor if the editor contents change.-onEventListOverlay :: TeamId- -> Lens' ChatState (ListOverlayState a b)- -- ^ Which overlay to dispatch to?- -> (KeyConfig -> KeyHandlerMap)- -- ^ The keybinding builder- -> Vty.Event- -- ^ The event- -> MH Bool-onEventListOverlay tId which keybindings =- handleKeyboardEvent keybindings $ \e -> do- -- Get the editor content before the event.- before <- listOverlaySearchString which-- -- First find a matching keybinding in the keybinding list.- handled <- handleKeyboardEvent (editingKeybindings tId (which.listOverlaySearchInput)) (const $ return ()) e-- -- If we didn't find a matching binding, just handle the event- -- as a normal editor input event.- when (not handled) $- mhHandleEventLensed (which.listOverlaySearchInput) E.handleEditorEvent e-- -- Get the editor content after the event. If the string changed,- -- start a new search.- after <- listOverlaySearchString which- when (before /= after) $ resetListOverlaySearch which
+ src/Matterhorn/State/ListWindow.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE RankNTypes #-}+module Matterhorn.State.ListWindow+ ( listWindowActivateCurrent+ , listWindowActivate+ , listWindowSearchString+ , listWindowMove+ , exitListWindow+ , enterListWindowMode+ , resetListWindowSearch+ , onEventListWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.Edit as E+import qualified Data.Text.Zipper as Z+import qualified Data.Vector as Vec+import Lens.Micro.Platform ( Lens', (%=), (.=) )+import Network.Mattermost.Types ( Session, TeamId )+import qualified Graphics.Vty as Vty++import Matterhorn.Types+import Matterhorn.State.Common+import Matterhorn.State.Editing ( editingKeybindings )+import Matterhorn.Events.Keybindings ( KeyConfig, KeyHandlerMap, handleKeyboardEvent )+++-- | Activate the specified list window's selected item by invoking the+-- window's configured enter keypress handler function.+listWindowActivateCurrent :: TeamId -> Lens' ChatState (ListWindowState a b) -> MH ()+listWindowActivateCurrent tId which = do+ mItem <- L.listSelectedElement <$> use (which.listWindowSearchResults)+ case mItem of+ Nothing -> return ()+ Just (_, val) -> listWindowActivate tId which val++-- | Activate the specified list window's selected item by invoking the+-- window's configured enter keypress handler function.+listWindowActivate :: TeamId -> Lens' ChatState (ListWindowState a b) -> a -> MH ()+listWindowActivate tId which val = do+ handler <- use (which.listWindowEnterHandler)+ activated <- handler val+ if activated+ then popMode tId+ else return ()++-- | Get the current search string for the specified window.+listWindowSearchString :: Lens' ChatState (ListWindowState a b) -> MH Text+listWindowSearchString which =+ (head . E.getEditContents) <$> use (which.listWindowSearchInput)++-- | Move the list cursor in the specified window.+listWindowMove :: Lens' ChatState (ListWindowState a b)+ -- ^ Which window+ -> (L.List Name a -> L.List Name a)+ -- ^ How to transform the list in the window+ -> MH ()+listWindowMove which how = which.listWindowSearchResults %= how++-- | Clear the state of the specified list window and return to the+-- Main mode.+exitListWindow :: TeamId+ -> Lens' ChatState (ListWindowState a b)+ -- ^ Which window to reset+ -> MH ()+exitListWindow tId which = do+ newList <- use (which.listWindowNewList)+ which.listWindowSearchResults .= newList mempty+ which.listWindowEnterHandler .= (const $ return False)+ popMode tId++-- | Initialize a list window with the specified arguments and switch+-- to the specified mode.+enterListWindowMode :: TeamId+ -> (Lens' ChatState (ListWindowState a b))+ -- ^ Which window to initialize+ -> Mode+ -- ^ The mode to change to+ -> b+ -- ^ The window's initial search scope+ -> (a -> MH Bool)+ -- ^ The window's enter keypress handler+ -> (b -> Session -> Text -> IO (Vec.Vector a))+ -- ^ The window's results fetcher function+ -> MH ()+enterListWindowMode tId which mode scope enterHandler fetcher = do+ which.listWindowSearchScope .= scope+ which.listWindowSearchInput.E.editContentsL %= Z.clearZipper+ which.listWindowEnterHandler .= enterHandler+ which.listWindowFetchResults .= fetcher+ which.listWindowSearching .= False+ newList <- use (which.listWindowNewList)+ which.listWindowSearchResults .= newList mempty+ pushMode tId mode+ resetListWindowSearch which++-- | Reset the window's search by initiating a new search request for+-- the string that is currently in the window's editor. This does+-- nothing if a search for this window is already in progress.+resetListWindowSearch :: Lens' ChatState (ListWindowState a b) -> MH ()+resetListWindowSearch which = do+ searchPending <- use (which.listWindowSearching)++ when (not searchPending) $ do+ searchString <- listWindowSearchString which+ which.listWindowSearching .= True+ newList <- use (which.listWindowNewList)+ session <- getSession+ scope <- use (which.listWindowSearchScope)+ fetcher <- use (which.listWindowFetchResults)+ doAsyncWith Preempt $ do+ results <- fetcher scope session searchString+ return $ Just $ do+ which.listWindowSearchResults .= newList results+ which.listWindowSearching .= False++ -- Now that the results are available, check to see if the+ -- search string changed since this request was submitted.+ -- If so, issue another search.+ afterSearchString <- listWindowSearchString which+ when (searchString /= afterSearchString) $ resetListWindowSearch which++-- | Generically handle an event for the list window state targeted+-- by the specified lens. Automatically dispatches new searches in the+-- window's editor if the editor contents change.+onEventListWindow :: Lens' ChatState (ListWindowState a b)+ -- ^ Which window to dispatch to?+ -> (KeyConfig -> KeyHandlerMap)+ -- ^ The keybinding builder+ -> Vty.Event+ -- ^ The event+ -> MH Bool+onEventListWindow which keybindings =+ handleEventWith [ handleKeyboardEvent keybindings+ , handleEditorEvent which+ ]++handleEditorEvent :: Lens' ChatState (ListWindowState a b) -> Vty.Event -> MH Bool+handleEditorEvent which e = do+ -- Get the editor content before the event.+ before <- listWindowSearchString which++ -- First find a matching keybinding in the keybinding list.+ handled <- handleKeyboardEvent (editingKeybindings (which.listWindowSearchInput)) e++ -- If we didn't find a matching binding, just handle the event as a+ -- normal editor input event.+ when (not handled) $+ mhHandleEventLensed (which.listWindowSearchInput) E.handleEditorEvent e++ -- Get the editor content after the event. If the string changed,+ -- start a new search.+ after <- listWindowSearchString which+ when (before /= after) $ resetListWindowSearch which++ return True
src/Matterhorn/State/MessageSelect.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.MessageSelect ( -- * Message selection mode@@ -22,6 +23,8 @@ , beginEditMessage , flagMessage , getSelectedMessage+ , openThreadWindow+ , exitMessageSelect ) where @@ -30,6 +33,7 @@ import Brick ( invalidateCache ) import Brick.Widgets.Edit ( applyEdit )+import Control.Monad ( replicateM_ ) import Data.Text.Zipper ( clearZipper, insertMany ) import Data.Maybe ( fromJust ) import Lens.Micro.Platform@@ -40,251 +44,251 @@ import Matterhorn.Clipboard ( copyToClipboard ) import Matterhorn.State.Common import Matterhorn.State.Links-import Matterhorn.State.Messages+import {-# SOURCE #-} Matterhorn.State.Messages ( asyncFetchMessagesForGap ) import Matterhorn.Types import Matterhorn.Types.RichText ( findVerbatimChunk, makePermalink ) import Matterhorn.Types.Common import Matterhorn.Windows.ViewMessage+import qualified Matterhorn.State.ThreadWindow as TW --- | In these modes, we allow access to the selected message state.-messageSelectCompatibleModes :: [Mode]-messageSelectCompatibleModes =- [ MessageSelect- , MessageSelectDeleteConfirm- , ReactionEmojiListOverlay- ]+getSelectedMessage :: Lens' ChatState (MessageInterface n i)+ -> ChatState+ -> Maybe Message+getSelectedMessage which st = do+ selMsgId <- selectMessageId $ st^.which.miMessageSelect+ let chanMsgs = st^.which.miMessages+ findMessage selMsgId chanMsgs -getSelectedMessage :: TeamId -> ChatState -> Maybe Message-getSelectedMessage tId st- | not (st^.csTeam(tId).tsMode `elem` messageSelectCompatibleModes) = Nothing- | otherwise = do- selMsgId <- selectMessageId $ st^.csTeam(tId).tsMessageSelect- cId <- st^.csCurrentChannelId(tId)- chan <- st^?csChannel(cId)- let chanMsgs = chan ^. ccContents . cdMessages- findMessage selMsgId chanMsgs+withSelectedMessage :: Lens' ChatState (MessageInterface n i)+ -> (Message -> MH ())+ -> MH ()+withSelectedMessage which act = do+ selectedMessage <- use (to (getSelectedMessage which))+ case selectedMessage of+ Nothing -> return ()+ Just m -> act m -beginMessageSelect :: TeamId -> MH ()-beginMessageSelect tId = do- withCurrentChannel tId $ \_ chan -> do- -- Invalidate the rendering cache since we cache messages to- -- speed up the selection UI responsiveness. (See Draw.Messages- -- for caching behavior.)- mh invalidateCache+beginMessageSelect :: Lens' ChatState (MessageInterface n i)+ -> MH ()+beginMessageSelect which = do+ -- Invalidate the rendering cache since we cache messages to speed+ -- up the selection UI responsiveness. (See Draw.Messages for+ -- caching behavior.)+ mh invalidateCache - -- Get the number of messages in the current channel and set- -- the currently selected message index to be the most recently- -- received message that corresponds to a Post (i.e. exclude- -- informative messages).- --- -- If we can't find one at all, we ignore the mode switch- -- request and just return.- let chanMsgs = chan ^. ccContents . cdMessages- recentMsg = getLatestSelectableMessage chanMsgs+ -- Get the number of messages in the listing and set the currently+ -- selected message index to be the most recently received message+ -- that corresponds to a Post (i.e. exclude informative messages).+ --+ -- If we can't find one at all, we ignore the mode switch request+ -- and just return.+ msgs <- use (which.miMessages)+ let recentMsg = getLatestSelectableMessage msgs - when (isJust recentMsg) $ do- setMode tId MessageSelect- csTeam(tId).tsMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId)+ when (isJust recentMsg) $ do+ which.miMode .= MessageSelect+ which.miMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId) +exitMessageSelect :: Lens' ChatState (MessageInterface n i) -> MH ()+exitMessageSelect which = do+ m <- use (which.miMode)+ when (m == MessageSelect) $+ which.miMode .= Compose+ -- | Tell the server that the message we currently have selected -- should have its flagged state toggled.-flagSelectedMessage :: TeamId -> MH ()-flagSelectedMessage tId = do- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg- | isFlaggable msg, Just pId <- messagePostId msg ->- flagMessage pId (not (msg^.mFlagged))- _ -> return ()+flagSelectedMessage :: Lens' ChatState (MessageInterface n i)+ -> MH ()+flagSelectedMessage which =+ withSelectedMessage which $ \msg ->+ when (isFlaggable msg) $ do+ case messagePostId msg of+ Just pId -> flagMessage pId (not (msg^.mFlagged))+ Nothing -> return () -- | Tell the server that the message we currently have selected -- should have its pinned state toggled.-pinSelectedMessage :: TeamId -> MH ()-pinSelectedMessage tId = do- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg- | isPinnable msg, Just pId <- messagePostId msg ->- pinMessage pId (not (msg^.mPinned))- _ -> return ()+pinSelectedMessage :: Lens' ChatState (MessageInterface n i)+ -> MH ()+pinSelectedMessage which =+ withSelectedMessage which $ \msg -> do+ when (isPinnable msg) $ do+ case messagePostId msg of+ Just pId -> pinMessage pId (not (msg^.mPinned))+ Nothing -> return () -viewSelectedMessage :: TeamId -> MH ()-viewSelectedMessage tId = do- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg- | not (isGap msg) -> viewMessage tId msg- _ -> return ()+viewSelectedMessage :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> MH ()+viewSelectedMessage tId which =+ withSelectedMessage which $ \msg ->+ when (not (isGap msg)) $ viewMessage tId msg -fillSelectedGap :: TeamId -> MH ()-fillSelectedGap tId = do- withCurrentChannel tId $ \cId _ -> do- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg- | isGap msg -> asyncFetchMessagesForGap cId msg- _ -> return ()+-- This will only work for channel message selection, not thread message+-- selection, since there will never be gap entries in the thread view.+-- But this is generalized enough that it looks like it should work for+-- thread views, but it won't because asyncFetchMessagesForGap only+-- works for channel message selection (and should).+fillSelectedGap :: Lens' ChatState (MessageInterface n i)+ -> MH ()+fillSelectedGap which = do+ cId <- use (which.miChannelId)+ withSelectedMessage which $ \msg ->+ when (isGap msg) $ asyncFetchMessagesForGap cId msg -copyPostLink :: TeamId -> MH ()-copyPostLink tId = do- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg | isPostMessage msg -> do- baseUrl <- getServerBaseUrl tId- let pId = fromJust (messageIdPostId =<< _mMessageId msg)- copyToClipboard $ makePermalink baseUrl pId- setMode tId Main- _ -> return ()+copyPostLink :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> MH ()+copyPostLink tId which =+ withSelectedMessage which $ \msg ->+ when (isPostMessage msg) $ do+ baseUrl <- getServerBaseUrl tId+ let pId = fromJust (messageIdPostId =<< _mMessageId msg)+ copyToClipboard $ makePermalink baseUrl pId+ exitMessageSelect which viewMessage :: TeamId -> Message -> MH () viewMessage tId m = do- let w = tabbedWindow VMTabMessage (viewMessageWindowTemplate tId) MessageSelect (78, 25)+ let w = tabbedWindow VMTabMessage (viewMessageWindowTemplate tId) (78, 25) csTeam(tId).tsViewedMessage .= Just (m, w) runTabShowHandlerFor (twValue w) w- setMode tId ViewMessage+ pushMode tId ViewMessage -yankSelectedMessageVerbatim :: TeamId -> MH ()-yankSelectedMessageVerbatim tId = do- selectedMessage <- use (to (getSelectedMessage tId))- case selectedMessage of- Nothing -> return ()- Just m -> do- setMode tId Main- case findVerbatimChunk (m^.mText) of- Just txt -> copyToClipboard txt- Nothing -> return ()+yankSelectedMessageVerbatim :: Lens' ChatState (MessageInterface n i)+ -> MH ()+yankSelectedMessageVerbatim which =+ withSelectedMessage which $ \msg -> do+ exitMessageSelect which+ case findVerbatimChunk (msg^.mText) of+ Just txt -> copyToClipboard txt+ Nothing -> return () -yankSelectedMessage :: TeamId -> MH ()-yankSelectedMessage tId = do- selectedMessage <- use (to (getSelectedMessage tId))- case selectedMessage of- Nothing -> return ()- Just m -> do- setMode tId Main- copyToClipboard $ m^.mMarkdownSource+openThreadWindow :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> MH ()+openThreadWindow tId which =+ withSelectedMessage which $ \msg -> do+ when (isPostMessage msg) $ do+ rootMsg <- getReplyRootMessage msg+ let p = fromJust $ rootMsg^.mOriginalPost+ case msg^.mChannelId of+ Nothing -> return ()+ Just cId -> do+ -- Leave message selection mode+ exitMessageSelect which+ TW.openThreadWindow tId cId (postId p) -openSelectedMessageURLs :: TeamId -> MH ()-openSelectedMessageURLs tId = whenMode tId MessageSelect $ do- mCurMsg <- use (to (getSelectedMessage tId))- curMsg <- case mCurMsg of- Nothing -> error "BUG: openSelectedMessageURLs: no selected message available"- Just m -> return m+yankSelectedMessage :: Lens' ChatState (MessageInterface n i)+ -> MH ()+yankSelectedMessage which =+ withSelectedMessage which $ \msg -> do+ exitMessageSelect which+ copyToClipboard $ msg^.mMarkdownSource - let urls = msgURLs curMsg- when (not (null urls)) $ do- mapM_ (openLinkTarget . _linkTarget) urls+openSelectedMessageURLs :: Lens' ChatState (MessageInterface n i)+ -> MH ()+openSelectedMessageURLs which =+ withSelectedMessage which $ \msg -> do+ let urls = msgURLs msg+ when (not (null urls)) $ do+ mapM_ (openLinkTarget . _linkTarget) urls -beginConfirmDeleteSelectedMessage :: TeamId -> MH ()-beginConfirmDeleteSelectedMessage tId = do+beginConfirmDeleteSelectedMessage :: TeamId+ -> Lens' ChatState (MessageInterface n i)+ -> MH ()+beginConfirmDeleteSelectedMessage tId which = do st <- use id- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg | isDeletable msg && isMine st msg ->- setMode tId MessageSelectDeleteConfirm- _ -> return ()+ target <- use (which.miTarget)+ withSelectedMessage which $ \msg ->+ when (isDeletable msg && isMine st msg) $+ pushMode tId $ MessageSelectDeleteConfirm target -messageSelectUp :: TeamId -> MH ()-messageSelectUp tId = do- withCurrentChannel tId $ \_ chan -> do- mode <- use (csTeam(tId).tsMode)- selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId)- case selected of- Just _ | mode == MessageSelect -> do- let chanMsgs = chan^.ccContents.cdMessages- nextMsgId = getPrevMessageId selected chanMsgs- csTeam(tId).tsMessageSelect .= MessageSelectState (nextMsgId <|> selected)- _ -> return ()+messageSelectUp :: Lens' ChatState (MessageInterface n i)+ -> MH ()+messageSelectUp which =+ withSelectedMessage which $ \msg -> do+ let selected = _mMessageId msg+ msgs <- use (which.miMessages)+ let nextMsgId = getPrevMessageId selected msgs+ which.miMessageSelect .= MessageSelectState (nextMsgId <|> selected) -messageSelectDown :: TeamId -> MH ()-messageSelectDown tId = do- withCurrentChannel tId $ \_ chan -> do- selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId)- case selected of- Just _ ->- whenMode tId MessageSelect $ do- let chanMsgs = chan^.ccContents.cdMessages- nextMsgId = getNextMessageId selected chanMsgs- csTeam(tId).tsMessageSelect .= MessageSelectState (nextMsgId <|> selected)- _ -> return ()+messageSelectDown :: Lens' ChatState (MessageInterface n i)+ -> MH ()+messageSelectDown which =+ withSelectedMessage which $ \msg -> do+ let selected = _mMessageId msg+ msgs <- use (which.miMessages)+ let nextMsgId = getNextMessageId selected msgs+ which.miMessageSelect .= MessageSelectState (nextMsgId <|> selected) -messageSelectDownBy :: TeamId -> Int -> MH ()-messageSelectDownBy tId amt- | amt <= 0 = return ()- | otherwise =- messageSelectDown tId >> messageSelectDownBy tId (amt - 1)+messageSelectDownBy :: Lens' ChatState (MessageInterface n i)+ -> Int+ -> MH ()+messageSelectDownBy which amt =+ replicateM_ amt $ messageSelectDown which -messageSelectUpBy :: TeamId -> Int -> MH ()-messageSelectUpBy tId amt- | amt <= 0 = return ()- | otherwise =- messageSelectUp tId >> messageSelectUpBy tId (amt - 1)+messageSelectUpBy :: Lens' ChatState (MessageInterface n i)+ -> Int+ -> MH ()+messageSelectUpBy which amt =+ replicateM_ amt $ messageSelectUp which -messageSelectFirst :: TeamId -> MH ()-messageSelectFirst tId = do- withCurrentChannel tId $ \_ chan -> do- selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId)- case selected of- Just _ ->- whenMode tId MessageSelect $ do- let chanMsgs = chan^.ccContents.cdMessages- case getEarliestSelectableMessage chanMsgs of- Just firstMsg ->- csTeam(tId).tsMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)- Nothing -> mhLog LogError "No first message found from current message?!"- _ -> return ()+messageSelectFirst :: Lens' ChatState (MessageInterface n i)+ -> MH ()+messageSelectFirst which =+ withSelectedMessage which $ \msg -> do+ let selected = _mMessageId msg+ msgs <- use (which.miMessages)+ case getEarliestSelectableMessage msgs of+ Just firstMsg ->+ which.miMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)+ Nothing -> mhLog LogError "No first message found from current message?!" -messageSelectLast :: TeamId -> MH ()-messageSelectLast tId = do- withCurrentChannel tId $ \_ chan -> do- selected <- use (csTeam(tId).tsMessageSelect.to selectMessageId)- case selected of- Just _ ->- whenMode tId MessageSelect $ do- let chanMsgs = chan^.ccContents.cdMessages- case getLatestSelectableMessage chanMsgs of- Just lastSelMsg ->- csTeam(tId).tsMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)- Nothing -> mhLog LogError "No last message found from current message?!"- _ -> return ()+messageSelectLast :: Lens' ChatState (MessageInterface n i)+ -> MH ()+messageSelectLast which =+ withSelectedMessage which $ \msg -> do+ let selected = _mMessageId msg+ msgs <- use (which.miMessages)+ case getLatestSelectableMessage msgs of+ Just lastSelMsg ->+ which.miMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)+ Nothing -> mhLog LogError "No last message found from current message?!" -deleteSelectedMessage :: TeamId -> MH ()-deleteSelectedMessage tId = do- withCurrentChannel tId $ \cId _ -> do- selectedMessage <- use (to (getSelectedMessage tId))- st <- use id- case selectedMessage of- Just msg | isMine st msg && isDeletable msg ->- case msg^.mOriginalPost of- Just p ->- doAsyncChannelMM Preempt cId- (\s _ -> MM.mmDeletePost (postId p) s)- (\_ _ -> Just $ do- csTeam(tId).tsEditState.cedEditMode .= NewPost- setMode tId Main)- Nothing -> return ()- _ -> return ()+deleteSelectedMessage :: Lens' ChatState (MessageInterface n i)+ -> MH ()+deleteSelectedMessage which = do+ st <- use id+ withSelectedMessage which $ \msg ->+ when (isMine st msg && isDeletable msg) $ do+ exitMessageSelect which+ case msg^.mOriginalPost of+ Just p ->+ doAsyncMM Preempt+ (\s -> MM.mmDeletePost (postId p) s)+ (const Nothing)+ Nothing -> return () -beginReplyCompose :: TeamId -> MH ()-beginReplyCompose tId = do- selected <- use (to (getSelectedMessage tId))- case selected of- Just msg | isReplyable msg -> do+beginReplyCompose :: Lens' ChatState (MessageInterface n i)+ -> MH ()+beginReplyCompose which = do+ withSelectedMessage which $ \msg ->+ when (isReplyable msg) $ do rootMsg <- getReplyRootMessage msg let p = fromJust $ rootMsg^.mOriginalPost- setMode tId Main- csTeam(tId).tsEditState.cedEditMode .= Replying rootMsg p- _ -> return ()+ exitMessageSelect which+ which.miEditor.esEditMode .= Replying rootMsg p -beginEditMessage :: TeamId -> MH ()-beginEditMessage tId = do- selected <- use (to (getSelectedMessage tId))+beginEditMessage :: Lens' ChatState (MessageInterface n i)+ -> MH ()+beginEditMessage which = do st <- use id- case selected of- Just msg | isMine st msg && isEditable msg -> do+ withSelectedMessage which $ \msg ->+ when (isMine st msg && isEditable msg) $ do let p = fromJust $ msg^.mOriginalPost- setMode tId Main- csTeam(tId).tsEditState.cedEditMode .= Editing p (msg^.mType)+ exitMessageSelect which+ which.miEditor.esEditMode .= Editing p (msg^.mType) -- If the post that we're editing is an emote, we need -- to strip the formatting because that's only there to -- indicate that the post is an emote. This is annoying and@@ -296,24 +300,23 @@ let toEdit = if isEmote msg then removeEmoteFormatting sanitized else sanitized- csTeam(tId).tsEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper)- _ -> return ()+ which.miEditor.esEditor %= applyEdit (insertMany toEdit . clearZipper) -- | Tell the server that we have flagged or unflagged a message. flagMessage :: PostId -> Bool -> MH () flagMessage pId f = do- session <- getSession- myId <- gets myUserId- doAsyncWith Normal $ do- let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost- doFlag myId pId session- return Nothing+ session <- getSession+ myId <- gets myUserId+ doAsyncWith Normal $ do+ let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost+ doFlag myId pId session+ return Nothing -- | Tell the server that we have pinned or unpinned a message. pinMessage :: PostId -> Bool -> MH () pinMessage pId f = do- session <- getSession- doAsyncWith Normal $ do- let doPin = if f then MM.mmPinPostToChannel else MM.mmUnpinPostToChannel- void $ doPin pId session- return Nothing+ session <- getSession+ doAsyncWith Normal $ do+ let doPin = if f then MM.mmPinPostToChannel else MM.mmUnpinPostToChannel+ void $ doPin pId session+ return Nothing
src/Matterhorn/State/Messages.hs view
@@ -16,13 +16,14 @@ , toggleMessageTimestamps , toggleVerbatimBlockTruncation , jumpToPost+ , addMessageToState ) where import Prelude () import Matterhorn.Prelude -import Brick.Main ( getVtyHandle, invalidateCacheEntry, invalidateCache )+import Brick.Main ( getVtyHandle, invalidateCache ) import qualified Brick.Widgets.FileBrowser as FB import Control.Exception ( SomeException, try ) import qualified Data.Aeson as A@@ -35,7 +36,7 @@ import Graphics.Vty ( outputIface ) import Graphics.Vty.Output.Interface ( ringTerminalBell ) import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~)- , to, at, traversed, filtered, ix, _1 )+ , to, at, traversed, filtered, ix, _1, _Just ) import Network.Mattermost import qualified Network.Mattermost.Endpoints as MM@@ -45,6 +46,8 @@ import Matterhorn.Constants import Matterhorn.State.Channels import Matterhorn.State.Common+import Matterhorn.State.ThreadWindow+import Matterhorn.State.MessageSelect import Matterhorn.State.Reactions import Matterhorn.State.Users import Matterhorn.TimeUtils@@ -69,7 +72,7 @@ addDisconnectGaps = mapM_ onEach . filteredChannelIds (const True) =<< use csChannels where onEach c = do addEndGap c clearPendingFlags c- mh $ invalidateCacheEntry (ChannelMessages c)+ invalidateChannelRenderingCache c -- | Websocket was disconnected, so all channels may now miss some -- messages@@ -98,11 +101,11 @@ csVerbatimTruncateSetting %= toggle clearPendingFlags :: ChannelId -> MH ()-clearPendingFlags c = csChannel(c).ccContents.cdFetchPending .= False+clearPendingFlags c = csChannel(c).ccInfo.cdFetchPending .= False addEndGap :: ChannelId -> MH () addEndGap cId = withChannel cId $ \chan ->- let lastmsg_ = chan^.ccContents.cdMessages.to reverseMessages.to lastMsg+ let lastmsg_ = chan^.ccMessageInterface.miMessages.to reverseMessages.to lastMsg lastIsGap = maybe False isGap lastmsg_ gapMsg = newGapMessage timeJustAfterLast timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_@@ -111,7 +114,7 @@ (T.pack "Disconnected. Will refresh when connected.") (C UnknownGapAfter) in unless lastIsGap- (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg))+ (csChannels %= modifyChannelById cId (ccMessageInterface.miMessages %~ addMessage gapMsg)) lastMsg :: RetrogradeMessages -> Maybe Message lastMsg = withFirstMessage id@@ -177,10 +180,13 @@ let (msg, mentionedUsers) = clientPostToMessage (toClientPost mBaseUrl new (new^.postRootIdL)) isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL) - csChannel (new^.postChannelIdL) . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg- mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)- mh $ invalidateCacheEntry $ RenderedMessage $ MessagePostId $ postId new+ csChannel (new^.postChannelIdL) . ccMessageInterface.miMessages . traversed . filtered isEditedMessage .= msg + invalidateChannelRenderingCache $ new^.postChannelIdL+ invalidateMessageRenderingCacheByPostId $ postId new++ editPostInOpenThread mTId new msg+ fetchMentionedUsers mentionedUsers when (postUserId new /= Just myId) $@@ -196,11 +202,35 @@ isReplyTo (new^.postIdL) m chan :: Traversal' ChatState ClientChannel chan = csChannel (new^.postChannelIdL)- chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)+ chan.ccMessageInterface.miMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True) chan %= adjustUpdated new- mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)- mh $ invalidateCacheEntry $ RenderedMessage $ MessagePostId $ postId new + withChannel (new^.postChannelIdL) $ \ch -> do+ case ch^.ccInfo.cdTeamId of+ Nothing -> return ()+ Just tId -> deletePostFromOpenThread tId new++ invalidateChannelRenderingCache $ new^.postChannelIdL+ invalidateMessageRenderingCacheByPostId $ postId new++deletePostFromOpenThread :: TeamId -> Post -> MH ()+deletePostFromOpenThread tId p = do+ let isDeletedMessage m = m^.mMessageId == Just (MessagePostId $ p^.postIdL) ||+ isReplyTo (p^.postIdL) m++ -- If the post being deleted is in the thread, we just need to+ -- remove it from the thread view. But if this effectively empties+ -- the thread, that's because this was the root. In that case we+ -- need to close down the window.+ threadInterfaceDeleteWhere tId (p^.postChannelIdL) isDeletedMessage++ ti <- use (csTeam(tId).tsThreadInterface)+ when (isJust ti) $ do+ isEmpty <- threadInterfaceEmpty tId+ when isEmpty $ do+ closeThreadWindow tId+ postInfoMessage "The thread you were viewing was deleted."+ addNewPostedMessage :: PostToAdd -> MH () addNewPostedMessage p = addMessageToState True True p >>= postProcessMessageAdd@@ -215,7 +245,7 @@ -- message following the added block of messages. addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd addObtainedMessages cId reqCnt addTrailingGap posts = do- mh $ invalidateCacheEntry (ChannelMessages cId)+ invalidateChannelRenderingCache cId if null $ posts^.postsOrderL then do when addTrailingGap $ -- Fetched at the end of the channel, but nothing was@@ -223,7 +253,7 @@ -- with no messages in it. Need to remove any gaps that -- exist at the end of the channel. csChannels %= modifyChannelById cId- (ccContents.cdMessages %~+ (ccMessageInterface.miMessages %~ \msgs -> let startPoint = join $ _mMessageId <$> getLatestPostMsg msgs in fst $ removeMatchesFromSubset isGap startPoint Nothing msgs) return NoAction@@ -242,7 +272,7 @@ earliestDate = postCreateAt $ (posts^.postsPostsL) HM.! earliestPId latestDate = postCreateAt $ (posts^.postsPostsL) HM.! latestPId - localMessages = chan^.ccContents . cdMessages+ localMessages = chan^.ccMessageInterface.miMessages -- Get a list of the duplicated message PostIds between -- the messages already in the channel and the new posts@@ -350,7 +380,7 @@ -- Do this with the updated copy of the channel's messages. withChannelOrDefault cId () $ \updchan -> do- let updMsgs = updchan ^. ccContents . cdMessages+ let updMsgs = updchan ^. ccMessageInterface.miMessages -- Remove any gaps in the added region. If there was an -- active message selection and it is one of the removed@@ -362,12 +392,12 @@ let (resultMessages, removedMessages) = removeMatchesFromSubset isGap removeStart removeEnd updMsgs csChannels %= modifyChannelById cId- (ccContents.cdMessages .~ resultMessages)+ (ccMessageInterface.miMessages .~ resultMessages) let processTeam tId = do -- Determine if the current selected message was one of the -- removed messages.- selMsgId <- use (csTeam(tId).tsMessageSelect.to selectMessageId)+ selMsgId <- use (channelMessageSelect(cId).to selectMessageId) let rmvdSel = do i <- selMsgId -- :: Maybe MessageId findMessage i removedMessages@@ -389,8 +419,8 @@ -- choice than allowing the user to perform select -- actions on a message that isn't the one they just -- selected.- setMode tId Main- csTeam(tId).tsMessageSelect .= MessageSelectState Nothing+ popMode tId+ channelMessageSelect(cId) .= MessageSelectState Nothing -- Add a gap at each end of the newly fetched data, unless: -- 1. there is an overlap@@ -405,7 +435,7 @@ -- select to first (earliest) message) case rmvdSelType of Just (C UnknownGapBefore) ->- csTeam(tId).tsMessageSelect .= MessageSelectState (pure $ MessagePostId earliestPId)+ channelMessageSelect(cId) .= MessageSelectState (pure $ MessagePostId earliestPId) _ -> return () else do -- add a gap at the start of the newly fetched block and@@ -413,11 +443,11 @@ -- the previously selected gap in this direction. gapMsg <- newGapMessage (justBefore earliestDate) True csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ addMessage gapMsg)+ (ccMessageInterface.miMessages %~ addMessage gapMsg) -- Move selection from old gap to new gap case rmvdSelType of Just (C UnknownGapBefore) -> do- csTeam(tId).tsMessageSelect .= MessageSelectState (gapMsg^.mMessageId)+ channelMessageSelect(cId) .= MessageSelectState (gapMsg^.mMessageId) _ -> return () if reAddGapAfter@@ -426,7 +456,7 @@ -- select to last (latest) message. case rmvdSelType of Just (C UnknownGapAfter) ->- csTeam(tId).tsMessageSelect .= MessageSelectState (pure $ MessagePostId latestPId)+ channelMessageSelect(cId) .= MessageSelectState (pure $ MessagePostId latestPId) _ -> return () else do -- add a gap at the end of the newly fetched block and@@ -434,11 +464,11 @@ -- the previously selected gap in this direction. gapMsg <- newGapMessage (justAfter latestDate) False csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ addMessage gapMsg)+ (ccMessageInterface.miMessages %~ addMessage gapMsg) -- Move selection from old gap to new gap case rmvdSelType of Just (C UnknownGapAfter) ->- csTeam(tId).tsMessageSelect .= MessageSelectState (gapMsg^.mMessageId)+ channelMessageSelect(cId) .= MessageSelectState (gapMsg^.mMessageId) _ -> return () case mTId of@@ -570,10 +600,10 @@ fetchMentionedUsers mentionedUsers csPostMap.at(postId new) .= Just msg'- mh $ invalidateCacheEntry (ChannelMessages cId)- mh $ invalidateCacheEntry $ RenderedMessage $ MessagePostId $ postId new+ invalidateChannelRenderingCache cId+ invalidateMessageRenderingCacheByPostId $ postId new csChannels %= modifyChannelById cId- ((ccContents.cdMessages %~ addMessage msg') .+ ((ccMessageInterface.miMessages %~ addMessage msg') . (if not ignoredJoinLeaveMessage then adjustUpdated new else id) . (\c -> if currCId == Just cId then c@@ -585,6 +615,12 @@ then c & ccInfo.cdMentionCount %~ succ else c) )++ -- Check for whether the post is part of a thread+ -- being viewed. If so, add the post to that thread+ -- window as well.+ addPostToOpenThread mTId new msg'+ asyncFetchReactionsForPost cId new asyncFetchAttachments new postedChanMessage@@ -631,6 +667,29 @@ doHandleAddedMessage +addPostToOpenThread :: Maybe TeamId -> Post -> Message -> MH ()+addPostToOpenThread Nothing _ _ = return ()+addPostToOpenThread (Just tId) new msg =+ case postRootId new of+ Nothing -> return ()+ Just parentId -> do+ mRoot <- preuse (maybeThreadInterface(tId)._Just.miRootPostId)+ when (mRoot == Just parentId) $+ modifyThreadMessages tId (new^.postChannelIdL) (addMessage msg)++editPostInOpenThread :: Maybe TeamId -> Post -> Message -> MH ()+editPostInOpenThread Nothing _ _ = return ()+editPostInOpenThread (Just tId) new msg =+ case postRootId new of+ Nothing -> return ()+ Just parentId -> do+ mRoot <- preuse (maybeThreadInterface(tId)._Just.miRootPostId)+ when (mRoot == Just parentId) $ do+ mhLog LogGeneral "editPostInOpenThread: updating message"+ let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)+ modifyEachThreadMessage tId (new^.postChannelIdL)+ (\m -> if isEditedMessage m then msg else m)+ -- | PostProcessMessageAdd is an internal value that informs the main -- code whether the user should be notified (e.g., ring the bell) or -- the server should be updated (e.g., that the channel has been@@ -797,9 +856,9 @@ asyncFetchMoreMessages = withCurrentTeam $ \tId -> withCurrentChannel tId $ \cId chan -> do- let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2+ let offset = max 0 $ length (chan^.ccMessageInterface.miMessages) - 2 page = offset `div` pageAmount- usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages)+ usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccMessageInterface.miMessages.to reverseMessages) sndOldestId = (messagePostId . snd) =<< usefulMsgs query = MM.defaultPostQuery { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId@@ -836,9 +895,9 @@ asyncFetchMessagesForGap cId gapMessage = when (isGap gapMessage) $ withChannel cId $ \chan ->- let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2+ let offset = max 0 $ length (chan^.ccMessageInterface.miMessages) - 2 page = offset `div` pageAmount- chanMsgs = chan^.ccContents.cdMessages+ chanMsgs = chan^.ccMessageInterface.miMessages fromMsg = Just gapMessage fetchNewer = case gapMessage^.mType of C UnknownGapAfter -> True@@ -915,7 +974,7 @@ sts <- use csConnectionStatus when (sts == Connected) $ do withCurrentChannel tId $ \cId chan -> do- let msgs = chan^.ccContents.cdMessages.to reverseMessages+ let msgs = chan^.ccMessageInterface.miMessages.to reverseMessages (numRemaining, gapInDisplayable, _, rel'pId, overlap) = foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs @@ -940,11 +999,11 @@ op = \s c -> MM.mmGetPostsForChannel c finalQuery s addTrailingGap = MM.postQueryBefore finalQuery == Nothing && MM.postQueryPage finalQuery == Just 0- when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do- csChannel(cId).ccContents.cdFetchPending .= True+ when ((not $ chan^.ccInfo.cdFetchPending) && gapInDisplayable) $ do+ csChannel(cId).ccInfo.cdFetchPending .= True doAsyncChannelMM Preempt cId op (\c p -> Just $ do- csChannel(c).ccContents.cdFetchPending .= False+ csChannel(c).ccInfo.cdFetchPending .= False addObtainedMessages c (-numToRequest) addTrailingGap p >>= postProcessMessageAdd) asyncFetchAttachments :: Post -> MH ()@@ -968,11 +1027,18 @@ | otherwise = m return $ Just $ do- csChannel(cId).ccContents.cdMessages.traversed %= addAttachment- mh $ do- invalidateCacheEntry $ ChannelMessages cId- invalidateCacheEntry $ RenderedMessage $ MessagePostId pId+ csChannelMessages(cId).traversed %= addAttachment + curTId <- use csCurrentTeamId+ withChannel cId $ \chan -> do+ let mTId = chan^.ccInfo.cdTeamId <|> curTId+ case mTId of+ Nothing -> return ()+ Just tId -> modifyEachThreadMessage tId cId addAttachment++ invalidateChannelRenderingCache cId+ invalidateMessageRenderingCacheByPostId pId+ -- | Given a post ID, switch to that post's channel and select the post -- in message selection mode. --@@ -994,8 +1060,8 @@ joinChannel' tId cId (Just $ jumpToPost pId) Just _ -> do setFocus tId cId- setMode tId MessageSelect- csTeam(tId).tsMessageSelect .= MessageSelectState (msg^.mMessageId)+ beginMessageSelect (csChannelMessageInterface(cId))+ channelMessageSelect(cId) .= MessageSelectState (msg^.mMessageId) Nothing -> error "INTERNAL: selected Post ID not associated with a channel" Nothing -> do
src/Matterhorn/State/Messages.hs-boot view
@@ -1,12 +1,27 @@ module Matterhorn.State.Messages- ( fetchVisibleIfNeeded+ ( PostToAdd(..)+ , fetchVisibleIfNeeded+ , addMessageToState+ , sendMessage+ , jumpToPost+ , asyncFetchMessagesForGap ) where -import Matterhorn.Types ( MH )-import Network.Mattermost.Types ( TeamId )+import Prelude ()+import Matterhorn.Prelude+import Matterhorn.Types ( MH, AttachmentData, EditMode )+import Matterhorn.Types.Messages ( Message )+import Network.Mattermost.Types ( ChannelId, TeamId, Post, PostId ) +data PostToAdd = OldPost Post | RecentPost Post Bool+data PostProcessMessageAdd+ -- State.Channels needs this in setFocusWith, but that creates an -- import cycle because several things in State.Messages need things in -- State.Channels. fetchVisibleIfNeeded :: TeamId -> MH ()+addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd+sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()+jumpToPost :: PostId -> MH ()+asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()
src/Matterhorn/State/NotifyPrefs.hs view
@@ -82,8 +82,7 @@ let props = chan^.ccInfo.cdNotifyProps user <- use csMe csTeam(tId).tsNotifyPrefs .= (Just (notifyPrefsForm tId (userNotifyProps user) props))- setMode tId EditNotifyPrefs+ pushMode tId EditNotifyPrefs exitEditNotifyPrefsMode :: TeamId -> MH ()-exitEditNotifyPrefsMode tId = do- setMode tId Main+exitEditNotifyPrefsMode = popMode
− src/Matterhorn/State/PostListOverlay.hs
@@ -1,147 +0,0 @@-module Matterhorn.State.PostListOverlay- ( enterFlaggedPostListMode- , enterPinnedPostListMode- , enterSearchResultPostListMode- , postListJumpToCurrent- , postListSelectUp- , postListSelectDown- , postListUnflagSelected- , exitPostListMode- )-where--import GHC.Exts ( IsList(..) )-import Prelude ()-import Matterhorn.Prelude--import qualified Data.Foldable as F-import qualified Data.Text as T-import Lens.Micro.Platform ( (.=) )-import Network.Mattermost.Endpoints-import Network.Mattermost.Types--import Matterhorn.State.Messages ( jumpToPost )-import Matterhorn.State.Common-import Matterhorn.State.MessageSelect-import Matterhorn.State.Messages ( addObtainedMessages- , asyncFetchMessagesSurrounding )-import Matterhorn.Types-import Matterhorn.Types.DirectionalSeq (emptyDirSeq)----- | Create a PostListOverlay with the given content description and--- with a specified list of messages.-enterPostListMode :: TeamId -> PostListContents -> Messages -> MH ()-enterPostListMode tId contents msgs = do- csTeam(tId).tsPostListOverlay.postListPosts .= msgs- let mlatest = getLatestPostMsg msgs- pId = mlatest >>= messagePostId- cId = mlatest >>= \m -> m^.mChannelId- csTeam(tId).tsPostListOverlay.postListSelected .= pId- setMode tId $ PostListOverlay contents- case (pId, cId) of- (Just p, Just c) -> asyncFetchMessagesSurrounding c p- _ -> return ()---- | Clear out the state of a PostListOverlay-exitPostListMode :: TeamId -> MH ()-exitPostListMode tId = do- csTeam(tId).tsPostListOverlay.postListPosts .= emptyDirSeq- csTeam(tId).tsPostListOverlay.postListSelected .= Nothing- setMode tId Main--createPostList :: TeamId -> PostListContents -> (Session -> IO Posts) -> MH ()-createPostList tId contentsType fetchOp = do- session <- getSession- doAsyncWith Preempt $ do- posts <- fetchOp session- return $ Just $ do- messages <- installMessagesFromPosts (Just tId) posts- -- n.b. do not use addNewPostedMessage because these messages- -- are not new, and so no notifications or channel highlighting- -- or other post-processing should be performed.- let plist = F.toList $ postsPosts posts- postsSpec p = Posts { postsPosts = fromList [(postId p, p)]- , postsOrder = fromList [postId p]- }- mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist- enterPostListMode tId contentsType messages----- | Create a PostListOverlay with flagged messages from the server.-enterFlaggedPostListMode :: TeamId -> MH ()-enterFlaggedPostListMode tId = do- createPostList tId PostListFlagged $- mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery---- | Create a PostListOverlay with pinned messages from the server for--- the current channel.-enterPinnedPostListMode :: TeamId -> MH ()-enterPinnedPostListMode tId =- withCurrentChannel tId $ \cId _ -> do- createPostList tId (PostListPinned cId) $ mmGetChannelPinnedPosts cId---- | Create a PostListOverlay with post search result messages from the--- server.-enterSearchResultPostListMode :: TeamId -> Text -> MH ()-enterSearchResultPostListMode tId terms- | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term."- | otherwise = do- enterPostListMode tId (PostListSearch terms True) noMessages- createPostList tId (PostListSearch terms False) $- mmSearchForTeamPosts tId (SearchPosts terms False)----- | Move the selection up in the PostListOverlay, which corresponds--- to finding a chronologically /newer/ message.-postListSelectDown :: TeamId -> MH ()-postListSelectDown tId = do- selId <- use (csTeam(tId).tsPostListOverlay.postListSelected)- posts <- use (csTeam(tId).tsPostListOverlay.postListPosts)- let nextMsg = getNextMessage (MessagePostId <$> selId) posts- case nextMsg of- Nothing -> return ()- Just m -> do- let pId = m^.mMessageId >>= messageIdPostId- csTeam(tId).tsPostListOverlay.postListSelected .= pId- case (m^.mChannelId, pId) of- (Just c, Just p) -> asyncFetchMessagesSurrounding c p- o -> mhLog LogError- (T.pack $ "postListSelectDown" <>- " unable to get channel or post ID: " <> show o)---- | Move the selection down in the PostListOverlay, which corresponds--- to finding a chronologically /old/ message.-postListSelectUp :: TeamId -> MH ()-postListSelectUp tId = do- selId <- use (csTeam(tId).tsPostListOverlay.postListSelected)- posts <- use (csTeam(tId).tsPostListOverlay.postListPosts)- let prevMsg = getPrevMessage (MessagePostId <$> selId) posts- case prevMsg of- Nothing -> return ()- Just m -> do- let pId = m^.mMessageId >>= messageIdPostId- csTeam(tId).tsPostListOverlay.postListSelected .= pId- case (m^.mChannelId, pId) of- (Just c, Just p) -> asyncFetchMessagesSurrounding c p- o -> mhLog LogError- (T.pack $ "postListSelectUp" <>- " unable to get channel or post ID: " <> show o)---- | Unflag the post currently selected in the PostListOverlay, if any-postListUnflagSelected :: TeamId -> MH ()-postListUnflagSelected tId = do- msgId <- use (csTeam(tId).tsPostListOverlay.postListSelected)- case msgId of- Nothing -> return ()- Just pId -> flagMessage pId False----- | Jumps to the specified message in the message's main channel--- display and changes to MessageSelectState.-postListJumpToCurrent :: TeamId -> MH ()-postListJumpToCurrent tId = do- msgId <- use (csTeam(tId).tsPostListOverlay.postListSelected)- case msgId of- Nothing -> return ()- Just pId -> jumpToPost pId
+ src/Matterhorn/State/PostListWindow.hs view
@@ -0,0 +1,147 @@+module Matterhorn.State.PostListWindow+ ( enterFlaggedPostListMode+ , enterPinnedPostListMode+ , enterSearchResultPostListMode+ , postListJumpToCurrent+ , postListSelectUp+ , postListSelectDown+ , postListUnflagSelected+ , exitPostListMode+ )+where++import GHC.Exts ( IsList(..) )+import Prelude ()+import Matterhorn.Prelude++import qualified Data.Foldable as F+import qualified Data.Text as T+import Lens.Micro.Platform ( (.=) )+import Network.Mattermost.Endpoints+import Network.Mattermost.Types++import Matterhorn.State.Messages ( jumpToPost )+import Matterhorn.State.Common+import Matterhorn.State.MessageSelect+import Matterhorn.State.Messages ( addObtainedMessages+ , asyncFetchMessagesSurrounding )+import Matterhorn.Types+import Matterhorn.Types.DirectionalSeq (emptyDirSeq)+++-- | Create a PostListWindow with the given content description and+-- with a specified list of messages.+enterPostListMode :: TeamId -> PostListContents -> Messages -> MH ()+enterPostListMode tId contents msgs = do+ csTeam(tId).tsPostListWindow.postListPosts .= msgs+ let mlatest = getLatestPostMsg msgs+ pId = mlatest >>= messagePostId+ cId = mlatest >>= \m -> m^.mChannelId+ csTeam(tId).tsPostListWindow.postListSelected .= pId+ pushMode tId $ PostListWindow contents+ case (pId, cId) of+ (Just p, Just c) -> asyncFetchMessagesSurrounding c p+ _ -> return ()++-- | Clear out the state of a PostListWindow+exitPostListMode :: TeamId -> MH ()+exitPostListMode tId = do+ csTeam(tId).tsPostListWindow.postListPosts .= emptyDirSeq+ csTeam(tId).tsPostListWindow.postListSelected .= Nothing+ popMode tId++createPostList :: TeamId -> PostListContents -> (Session -> IO Posts) -> MH ()+createPostList tId contentsType fetchOp = do+ session <- getSession+ doAsyncWith Preempt $ do+ posts <- fetchOp session+ return $ Just $ do+ messages <- installMessagesFromPosts (Just tId) posts+ -- n.b. do not use addNewPostedMessage because these messages+ -- are not new, and so no notifications or channel highlighting+ -- or other post-processing should be performed.+ let plist = F.toList $ postsPosts posts+ postsSpec p = Posts { postsPosts = fromList [(postId p, p)]+ , postsOrder = fromList [postId p]+ }+ mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist+ enterPostListMode tId contentsType messages+++-- | Create a PostListWindow with flagged messages from the server.+enterFlaggedPostListMode :: TeamId -> MH ()+enterFlaggedPostListMode tId = do+ createPostList tId PostListFlagged $+ mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery++-- | Create a PostListWindow with pinned messages from the server for+-- the current channel.+enterPinnedPostListMode :: TeamId -> MH ()+enterPinnedPostListMode tId =+ withCurrentChannel tId $ \cId _ -> do+ createPostList tId (PostListPinned cId) $ mmGetChannelPinnedPosts cId++-- | Create a PostListWindow with post search result messages from the+-- server.+enterSearchResultPostListMode :: TeamId -> Text -> MH ()+enterSearchResultPostListMode tId terms+ | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term."+ | otherwise = do+ enterPostListMode tId (PostListSearch terms True) noMessages+ createPostList tId (PostListSearch terms False) $+ mmSearchForTeamPosts tId (SearchPosts terms False)+++-- | Move the selection up in the PostListWindow, which corresponds+-- to finding a chronologically /newer/ message.+postListSelectDown :: TeamId -> MH ()+postListSelectDown tId = do+ selId <- use (csTeam(tId).tsPostListWindow.postListSelected)+ posts <- use (csTeam(tId).tsPostListWindow.postListPosts)+ let nextMsg = getNextMessage (MessagePostId <$> selId) posts+ case nextMsg of+ Nothing -> return ()+ Just m -> do+ let pId = m^.mMessageId >>= messageIdPostId+ csTeam(tId).tsPostListWindow.postListSelected .= pId+ case (m^.mChannelId, pId) of+ (Just c, Just p) -> asyncFetchMessagesSurrounding c p+ o -> mhLog LogError+ (T.pack $ "postListSelectDown" <>+ " unable to get channel or post ID: " <> show o)++-- | Move the selection down in the PostListWindow, which corresponds+-- to finding a chronologically /old/ message.+postListSelectUp :: TeamId -> MH ()+postListSelectUp tId = do+ selId <- use (csTeam(tId).tsPostListWindow.postListSelected)+ posts <- use (csTeam(tId).tsPostListWindow.postListPosts)+ let prevMsg = getPrevMessage (MessagePostId <$> selId) posts+ case prevMsg of+ Nothing -> return ()+ Just m -> do+ let pId = m^.mMessageId >>= messageIdPostId+ csTeam(tId).tsPostListWindow.postListSelected .= pId+ case (m^.mChannelId, pId) of+ (Just c, Just p) -> asyncFetchMessagesSurrounding c p+ o -> mhLog LogError+ (T.pack $ "postListSelectUp" <>+ " unable to get channel or post ID: " <> show o)++-- | Unflag the post currently selected in the PostListWindow, if any+postListUnflagSelected :: TeamId -> MH ()+postListUnflagSelected tId = do+ msgId <- use (csTeam(tId).tsPostListWindow.postListSelected)+ case msgId of+ Nothing -> return ()+ Just pId -> flagMessage pId False+++-- | Jumps to the specified message in the message's main channel+-- display and changes to MessageSelectState.+postListJumpToCurrent :: TeamId -> MH ()+postListJumpToCurrent tId = do+ msgId <- use (csTeam(tId).tsPostListWindow.postListSelected)+ case msgId of+ Nothing -> return ()+ Just pId -> jumpToPost pId
− src/Matterhorn/State/ReactionEmojiListOverlay.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE TupleSections #-}-module Matterhorn.State.ReactionEmojiListOverlay- ( enterReactionEmojiListOverlayMode-- , reactionEmojiListSelectDown- , reactionEmojiListSelectUp- , reactionEmojiListPageDown- , reactionEmojiListPageUp- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Brick.Widgets.List as L-import qualified Data.Vector as Vec-import qualified Data.Text as T-import qualified Data.Map as M-import qualified Data.Set as Set-import Data.Function ( on )-import Data.List ( nubBy )-import Lens.Micro.Platform ( to )--import Network.Mattermost.Types--import Matterhorn.Emoji-import Matterhorn.State.ListOverlay-import Matterhorn.State.MessageSelect-import Matterhorn.Types-import Matterhorn.State.Reactions ( updateReaction )---enterReactionEmojiListOverlayMode :: TeamId -> MH ()-enterReactionEmojiListOverlayMode tId = do- selectedMessage <- use (to (getSelectedMessage tId))- case selectedMessage of- Nothing -> return ()- Just msg -> do- em <- use (csResources.crEmoji)- myId <- gets myUserId- enterListOverlayMode tId (csTeam(tId).tsReactionEmojiListOverlay) ReactionEmojiListOverlay- () (enterHandler tId) (fetchResults myId msg em)--enterHandler :: TeamId -> (Bool, T.Text) -> MH Bool-enterHandler tId (mine, e) = do- selectedMessage <- use (to (getSelectedMessage tId))- case selectedMessage of- Nothing -> return False- Just m -> do- case m^.mOriginalPost of- Nothing -> return False- Just p -> do- updateReaction (postId p) e (not mine)- return True--fetchResults :: UserId- -- ^ My user ID, so we can see which reactions I haven't- -- posted- -> Message- -- ^ The selected message, so we can include its current- -- reactions in the list- -> EmojiCollection- -- ^ The emoji collection- -> ()- -- ^ The scope to search- -> Session- -- ^ The connection session- -> Text- -- ^ The search string- -> IO (Vec.Vector (Bool, T.Text))-fetchResults myId msg em () session searchString = do- let currentReactions = [ (myId `Set.member` uIds, k)- | (k, uIds) <- M.toList (msg^.mReactions)- ]- matchingCurrentOtherReactions = [ (mine, r) | (mine, r) <- currentReactions- , matchesEmoji searchString r- , not mine- ]- matchingCurrentMyReactions = [ (mine, r) | (mine, r) <- currentReactions- , matchesEmoji searchString r- , mine- ]- serverMatches <- getMatchingEmoji session em searchString- return $ Vec.fromList $ nubBy ((==) `on` snd) $- matchingCurrentOtherReactions <> matchingCurrentMyReactions <> ((False,) <$> serverMatches)---- | Move the selection up in the emoji list overlay by one emoji.-reactionEmojiListSelectUp :: TeamId -> MH ()-reactionEmojiListSelectUp tId = reactionEmojiListMove tId L.listMoveUp---- | Move the selection down in the emoji list overlay by one emoji.-reactionEmojiListSelectDown :: TeamId -> MH ()-reactionEmojiListSelectDown tId = reactionEmojiListMove tId L.listMoveDown---- | Move the selection up in the emoji list overlay by a page of emoji--- (ReactionEmojiListPageSize).-reactionEmojiListPageUp :: TeamId -> MH ()-reactionEmojiListPageUp tId = reactionEmojiListMove tId (L.listMoveBy (-1 * reactionEmojiListPageSize))---- | Move the selection down in the emoji list overlay by a page of emoji--- (ReactionEmojiListPageSize).-reactionEmojiListPageDown :: TeamId -> MH ()-reactionEmojiListPageDown tId = reactionEmojiListMove tId (L.listMoveBy reactionEmojiListPageSize)---- | Transform the emoji list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-reactionEmojiListMove :: TeamId -> (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH ()-reactionEmojiListMove tId = listOverlayMove (csTeam(tId).tsReactionEmojiListOverlay)---- | The number of emoji in a "page" for cursor movement purposes.-reactionEmojiListPageSize :: Int-reactionEmojiListPageSize = 10
+ src/Matterhorn/State/ReactionEmojiListWindow.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+module Matterhorn.State.ReactionEmojiListWindow+ ( enterReactionEmojiListWindowMode++ , reactionEmojiListSelectDown+ , reactionEmojiListSelectUp+ , reactionEmojiListPageDown+ , reactionEmojiListPageUp+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Data.Vector as Vec+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.Set as Set+import Data.Function ( on )+import Data.List ( nubBy )++import Network.Mattermost.Types++import Matterhorn.Emoji+import Matterhorn.State.ListWindow+import Matterhorn.Types+import Matterhorn.State.Reactions ( updateReaction )+++enterReactionEmojiListWindowMode :: TeamId -> Message -> MH ()+enterReactionEmojiListWindowMode tId msg = do+ em <- use (csResources.crEmoji)+ myId <- gets myUserId+ enterListWindowMode tId (csTeam(tId).tsReactionEmojiListWindow) ReactionEmojiListWindow+ () (enterHandler msg) (fetchResults myId msg em)++enterHandler :: Message -> (Bool, T.Text) -> MH Bool+enterHandler msg (mine, e) = do+ case msg^.mOriginalPost of+ Nothing -> return False+ Just p -> do+ updateReaction (postId p) e (not mine)+ return True++fetchResults :: UserId+ -- ^ My user ID, so we can see which reactions I haven't+ -- posted+ -> Message+ -- ^ The selected message, so we can include its current+ -- reactions in the list+ -> EmojiCollection+ -- ^ The emoji collection+ -> ()+ -- ^ The scope to search+ -> Session+ -- ^ The connection session+ -> Text+ -- ^ The search string+ -> IO (Vec.Vector (Bool, T.Text))+fetchResults myId msg em () session searchString = do+ let currentReactions = [ (myId `Set.member` uIds, k)+ | (k, uIds) <- M.toList (msg^.mReactions)+ ]+ matchingCurrentOtherReactions = [ (mine, r) | (mine, r) <- currentReactions+ , matchesEmoji searchString r+ , not mine+ ]+ matchingCurrentMyReactions = [ (mine, r) | (mine, r) <- currentReactions+ , matchesEmoji searchString r+ , mine+ ]+ serverMatches <- getMatchingEmoji session em searchString+ return $ Vec.fromList $ nubBy ((==) `on` snd) $+ matchingCurrentOtherReactions <> matchingCurrentMyReactions <> ((False,) <$> serverMatches)++-- | Move the selection up in the emoji list window by one emoji.+reactionEmojiListSelectUp :: TeamId -> MH ()+reactionEmojiListSelectUp tId = reactionEmojiListMove tId L.listMoveUp++-- | Move the selection down in the emoji list window by one emoji.+reactionEmojiListSelectDown :: TeamId -> MH ()+reactionEmojiListSelectDown tId = reactionEmojiListMove tId L.listMoveDown++-- | Move the selection up in the emoji list window by a page of emoji+-- (ReactionEmojiListPageSize).+reactionEmojiListPageUp :: TeamId -> MH ()+reactionEmojiListPageUp tId = reactionEmojiListMove tId (L.listMoveBy (-1 * reactionEmojiListPageSize))++-- | Move the selection down in the emoji list window by a page of emoji+-- (ReactionEmojiListPageSize).+reactionEmojiListPageDown :: TeamId -> MH ()+reactionEmojiListPageDown tId = reactionEmojiListMove tId (L.listMoveBy reactionEmojiListPageSize)++-- | Transform the emoji list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+reactionEmojiListMove :: TeamId -> (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH ()+reactionEmojiListMove tId = listWindowMove (csTeam(tId).tsReactionEmojiListWindow)++-- | The number of emoji in a "page" for cursor movement purposes.+reactionEmojiListPageSize :: Int+reactionEmojiListPageSize = 10
src/Matterhorn/State/Reactions.hs view
@@ -10,7 +10,6 @@ import Prelude () import Matterhorn.Prelude -import Brick.Main ( invalidateCacheEntry ) import qualified Data.Map.Strict as Map import Lens.Micro.Platform import qualified Data.Set as S@@ -20,7 +19,7 @@ import Network.Mattermost.Types import Matterhorn.State.Async-import Matterhorn.State.Common ( fetchMentionedUsers )+import Matterhorn.State.Common import Matterhorn.Types @@ -41,8 +40,15 @@ -- incoming reactions. addReactions :: ChannelId -> [Reaction] -> MH () addReactions cId rs = do- mh $ invalidateCacheEntry $ ChannelMessages cId- csChannel(cId).ccContents.cdMessages %= fmap upd+ invalidateChannelRenderingCache cId+ csChannelMessages(cId) %= fmap upd++ -- Also update any open thread for the corresponding channel's team+ withChannel cId $ \chan -> do+ case chan^.ccInfo.cdTeamId of+ Nothing -> return ()+ Just tId -> modifyThreadMessages tId cId (fmap upd)+ let mentions = S.fromList $ UserIdMention <$> reactionUserId <$> rs fetchMentionedUsers mentions invalidateRenderCache@@ -53,9 +59,8 @@ | otherwise = id insertAll mId msg = foldr (insert mId) msg rs invalidateRenderCache = do- let cacheIds = map cacheIdOf rs- mh $ mapM_ invalidateCacheEntry cacheIds- cacheIdOf r = RenderedMessage $ MessagePostId (r^.reactionPostIdL)+ forM_ rs $ \r ->+ invalidateMessageRenderingCacheByPostId $ r^.reactionPostIdL -- | Remove the specified reaction from its message in the specified -- channel. This should only be called in response to a server event@@ -64,15 +69,22 @@ -- rendered message corresponding to the removed reaction. removeReaction :: Reaction -> ChannelId -> MH () removeReaction r cId = do- mh $ invalidateCacheEntry $ ChannelMessages cId- csChannel(cId).ccContents.cdMessages %= fmap upd+ invalidateChannelRenderingCache cId+ csChannelMessages(cId) %= fmap upd++ -- Also update any open thread for the corresponding channel's team+ withChannel cId $ \chan -> do+ case chan^.ccInfo.cdTeamId of+ Nothing -> return ()+ Just tId -> modifyThreadMessages tId cId (fmap upd)+ invalidateRenderCache where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) = m & mReactions %~ (Map.alter delReaction (r^.reactionEmojiNameL)) | otherwise = m delReaction mUs = S.delete (r^.reactionUserIdL) <$> mUs invalidateRenderCache =- mh $ invalidateCacheEntry $ RenderedMessage $ MessagePostId (r^.reactionPostIdL)+ invalidateMessageRenderingCacheByPostId $ r^.reactionPostIdL -- | Set or unset a reaction on a post. updateReaction :: PostId -> Text -> Bool -> MH ()
src/Matterhorn/State/SaveAttachmentWindow.hs view
@@ -1,19 +1,23 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.SaveAttachmentWindow ( openSaveAttachmentWindow+ , closeSaveAttachmentWindow ) where import Prelude () import Matterhorn.Prelude+import Brick ( getName ) import Brick.Widgets.List ( listSelectedElement ) -import Lens.Micro.Platform ( (.=), to )+import Lens.Micro.Platform ( Lens', (.=), to ) -import Network.Mattermost.Types ( TeamId, fileInfoName )+import Network.Mattermost.Types ( fileInfoName ) import Network.Mattermost.Endpoints ( mmGetMetadataForFile ) import Matterhorn.Types import Matterhorn.State.Common+import Matterhorn.State.Teams ( newSaveAttachmentDialog ) -- | If the currently selected link in the URL list is for an@@ -21,9 +25,9 @@ -- to save the attachment. If the URL list is empty or if the selected -- entry is not for an attachment, this returns to the Main mode but -- otherwise does nothing.-openSaveAttachmentWindow :: TeamId -> MH ()-openSaveAttachmentWindow tId = do- selected <- use (csTeam(tId).tsUrlList.to listSelectedElement)+openSaveAttachmentWindow :: Lens' ChatState (MessageInterface Name i) -> MH ()+openSaveAttachmentWindow which = do+ selected <- use (which.miUrlList.ulList.to listSelectedElement) case selected of Nothing -> return () Just (_, (_, link)) ->@@ -33,8 +37,17 @@ doAsyncWith Normal $ do info <- mmGetMetadataForFile fId session return $ Just $ do- csTeam(tId).tsSaveAttachmentDialog .= newSaveAttachmentDialog tId (fileInfoName info)- setMode tId $ SaveAttachmentWindow link+ -- Use the message interface's URL list name+ -- as a unique basis for the names of the UI+ -- elements in the attachment dialog+ listName <- getName <$> use (which.miUrlList.ulList)+ which.miSaveAttachmentDialog .= newSaveAttachmentDialog listName (fileInfoName info)+ which.miMode .= SaveAttachment link _ -> -- The selected link is not for an attachment. return ()++closeSaveAttachmentWindow :: Lens' ChatState (MessageInterface n i)+ -> MH ()+closeSaveAttachmentWindow which =+ which.miMode .= Compose
src/Matterhorn/State/Setup.hs view
@@ -149,6 +149,8 @@ Right e -> return $ Right e Left _ -> loadEmoji =<< bundledEmojiJsonPath + spResult <- maybeStartSpellChecker config+ let cr = ChatResources { _crSession = session , _crWebsocketThreadId = Nothing , _crConn = cd@@ -164,6 +166,7 @@ , _crSyntaxMap = mempty , _crLogManager = logMgr , _crEmoji = emoji+ , _crSpellChecker = spResult } st <- initializeState cr initialTeamId teams me
src/Matterhorn/State/Setup/Threads.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module Matterhorn.State.Setup.Threads ( startUserStatusUpdateThread@@ -5,6 +6,7 @@ , startSubprocessLoggerThread , startTimezoneMonitorThread , maybeStartSpellChecker+ , newSpellCheckTimer , startAsyncWorkerThread , startSyntaxMapLoaderThread , module Matterhorn.State.Setup.Threads.Logging@@ -89,8 +91,8 @@ STM.atomically $ STM.writeTChan requestChan $ return $ Just $ do now <- liftIO getCurrentTime let expiry = addUTCTime (- userTypingExpiryInterval) now- let expireUsers c = c & ccInfo.cdTypingUsers %~ expireTypingUsers expiry- csChannels . mapped %= expireUsers+ expireUsers c = c & ccMessageInterface.miEditor.esEphemeral.eesTypingUsers %~ expireTypingUsers expiry+ csChannels . chanMap . mapped %= expireUsers threadDelay refreshIntervalMicros @@ -159,22 +161,23 @@ void $ forkIO (timezoneMonitor tz) -maybeStartSpellChecker :: TeamId -> Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ()))-maybeStartSpellChecker tId config eventQueue = do+spellCheckerTimeout :: Int+spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms++maybeStartSpellChecker :: Config -> IO (Maybe Aspell)+maybeStartSpellChecker config = do case configEnableAspell config of False -> return Nothing True -> do let aspellOpts = catMaybes [ UseDictionary <$> (configAspellDictionary config) ]- spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms- asResult <- either (const Nothing) Just <$> startAspell aspellOpts- case asResult of- Nothing -> return Nothing- Just as -> do- resetSCChan <- startSpellCheckerThread tId eventQueue spellCheckerTimeout- let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan ()- return $ Just (as, resetSCTimer)+ either (const Nothing) Just <$> startAspell aspellOpts +newSpellCheckTimer :: Aspell -> BChan MHEvent -> MessageInterfaceTarget -> IO (IO ())+newSpellCheckTimer checker eventQueue target = do+ resetSCChan <- startSpellCheckerThread checker eventQueue target spellCheckerTimeout+ return $ STM.atomically $ STM.writeTChan resetSCChan ()+ -- Start the background spell checker delay thread. -- -- The purpose of this thread is to postpone the spell checker query@@ -201,14 +204,18 @@ -- The worker thread works by reading a timer from its queue, waiting -- until the timer expires, and then injecting an event into the main -- event loop to request a spell check.-startSpellCheckerThread :: TeamId+startSpellCheckerThread :: Aspell+ -- ^ The spell checker handle to use -> BChan MHEvent -- ^ The main event loop's event channel.+ -> MessageInterfaceTarget+ -- ^ The target of the editor whose contents+ -- should be spell checked -> Int -- ^ The number of microseconds to wait before -- requesting a spell check. -> IO (STM.TChan ())-startSpellCheckerThread tId eventChan spellCheckTimeout = do+startSpellCheckerThread checker eventChan target spellCheckTimeout = do delayWakeupChan <- STM.atomically STM.newTChan delayWorkerChan <- STM.atomically STM.newTChan delVar <- STM.atomically $ STM.newTVar Nothing@@ -217,7 +224,7 @@ -- requests a spell check. void $ forkIO $ forever $ do STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan- writeBChan eventChan (RespEvent $ requestSpellCheck tId)+ writeBChan eventChan (RespEvent $ requestSpellCheck checker target) -- The delay manager waits for requests to start a delay timer and -- signals the worker to begin waiting.
src/Matterhorn/State/Teams.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.Teams ( nextTeam , prevTeam@@ -8,33 +9,54 @@ , moveCurrentTeamLeft , moveCurrentTeamRight , setTeam+ , newSaveAttachmentDialog+ , newChannelTopicDialog+ , newThreadInterface+ , makeClientChannel+ , cycleTeamMessageInterfaceFocus ) where import Prelude () import Matterhorn.Prelude +import Brick ( getName )+import qualified Brick.BChan as BCH import Brick.Main ( invalidateCache, hScrollToBeginning, viewportScroll, makeVisible )+import Brick.Widgets.List ( list )+import Brick.Widgets.Edit ( editor, applyEdit )+import Brick.Focus ( focusRing ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( getCurrentTime )+import qualified Data.Text.Zipper as Z2 import qualified Data.HashMap.Strict as HM import Lens.Micro.Platform ( (%=), (.=), at )+import Text.Aspell ( Aspell ) -import Network.Mattermost.Lenses ( userIdL )-import Network.Mattermost.Types ( TeamId, Team, User, userId+import Network.Mattermost.Lenses ( userIdL, channelTypeL, channelPurposeL+ , channelHeaderL, channelTeamIdL, channelIdL+ , channelLastPostAtL+ )+import Network.Mattermost.Types ( TeamId, Team, Channel, User, userId , getId, channelId, teamId, UserParam(..)- , teamOrderPref+ , teamOrderPref, Post, ChannelId, postId+ , emptyChannelNotifyProps, UserId+ , channelName, Type(..), channelDisplayName ) import qualified Network.Mattermost.Endpoints as MM import Matterhorn.Types+import Matterhorn.Types.Common+import Matterhorn.Types.DirectionalSeq ( emptyDirSeq )+import Matterhorn.Types.NonemptyStack import Matterhorn.LastRunState import Matterhorn.State.Async import Matterhorn.State.ChannelList import Matterhorn.State.Channels-import Matterhorn.State.Messages-import Matterhorn.State.Setup.Threads ( maybeStartSpellChecker )+import {-# SOURCE #-} Matterhorn.State.ThreadWindow+import {-# SOURCE #-} Matterhorn.State.Messages+import Matterhorn.State.Setup.Threads ( newSpellCheckTimer ) import qualified Matterhorn.Zipper as Z @@ -168,17 +190,17 @@ let tId = teamId team session = getResourceSession cr config = cr^.crConfiguration+ eventQueue = cr^.crEventQueue - -- Create a predicate to find the last selected channel by reading- -- the run state file. If unable to read or decode or validate the- -- file, this predicate is just `isTownSquare`.- isLastSelectedChannel <- do- result <- readLastRunState tId- case result of- Right lrs | isValidLastRunState cr me lrs -> return $ \c ->- Just (channelId c) == lrs^.lrsSelectedChannelId- _ -> return isTownSquare+ lrsResult <- readLastRunState tId+ let mLrs = case lrsResult of+ Right lrs | isValidLastRunState cr me lrs -> Just lrs+ _ -> Nothing + -- Create a predicate to find the last selected channel by+ -- checking the last run state.+ isLastSelectedChannel = maybe isTownSquare (\lrs c -> Just (channelId c) == lrs^.lrsSelectedChannelId) mLrs+ -- Get all channels, but filter down to just the one we want -- to start in. We get all, rather than requesting by name or -- ID, because we don't know whether the server will give us a@@ -194,12 +216,9 @@ -- Since the only channel we are dealing with is by construction the -- last channel, we don't have to consider other cases here: chanPairs <- forM (toList chans) $ \c -> do- cChannel <- makeClientChannel (userId me) c+ cChannel <- makeClientChannel eventQueue (cr^.crSpellChecker) (userId me) (Just tId) c return (getId c, cChannel) - -- Start the spell checker and spell check timer, if configured- spResult <- maybeStartSpellChecker tId config (cr^.crEventQueue)- now <- getCurrentTime let chanIds = mkChannelZipperList (config^.configChannelListSortingL) now config tId Nothing (cr^.crUserPreferences)@@ -207,8 +226,18 @@ chanZip = Z.fromList chanIds clientChans = foldr (uncurry addChannel) noChannels chanPairs - return (newTeamState config team chanZip spResult, clientChans)+ -- If the configuration says to open any last open thread, then+ -- schedule it to be opened.+ when (configShowLastOpenThread config) $ do+ let maybeOpenThread = do+ lrs <- mLrs+ (cId, pId) <- lrs^.lrsOpenThread+ return $ scheduleMH cr (openThreadWindow tId cId pId)+ fromMaybe (return ()) maybeOpenThread + let ts = newTeamState config team chanZip+ return (ts, clientChans)+ -- | Add a new 'TeamState' and corresponding channels to the application -- state. addTeamState :: TeamState -> ClientChannels -> MH ()@@ -231,3 +260,208 @@ removeTeam tId = do csTeams.at tId .= Nothing setTeamFocusWith $ Z.filterZipper (/= tId)++cycleTeamMessageInterfaceFocus :: TeamId -> MH ()+cycleTeamMessageInterfaceFocus tId =+ csTeam(tId) %= messageInterfaceFocusNext++emptyEditStateForChannel :: Maybe Aspell -> BCH.BChan MHEvent -> Maybe TeamId -> ChannelId -> IO (EditState Name)+emptyEditStateForChannel checker eventQueue tId cId = do+ reset <- case checker of+ Nothing -> return Nothing+ Just as -> Just <$> (newSpellCheckTimer as eventQueue $ MIChannel cId)+ let editorName = MessageInput cId+ attachmentListName = AttachmentList cId+ return $ newEditState editorName attachmentListName tId cId NewPost True reset++emptyEditStateForThread :: Maybe Aspell -> BCH.BChan MHEvent -> TeamId -> ChannelId -> EditMode -> IO (EditState Name)+emptyEditStateForThread checker eventQueue tId cId initialEditMode = do+ reset <- case checker of+ Nothing -> return Nothing+ Just as -> Just <$> (newSpellCheckTimer as eventQueue $ MITeamThread tId)+ let editorName = ThreadMessageInput cId+ attachmentListName = ThreadEditorAttachmentList cId+ return $ newEditState editorName attachmentListName (Just tId) cId initialEditMode False reset++newThreadInterface :: Maybe Aspell+ -> BCH.BChan MHEvent+ -> TeamId+ -> ChannelId+ -> Message+ -> Post+ -> Messages+ -> IO ThreadInterface+newThreadInterface checker eventQueue tId cId rootMsg rootPost msgs = do+ es <- emptyEditStateForThread checker eventQueue tId cId (Replying rootMsg rootPost)+ return $ newMessageInterface cId (postId rootPost) msgs es (MITeamThread tId) (FromThreadIn cId)++newChannelMessageInterface :: Maybe Aspell+ -> BCH.BChan MHEvent+ -> Maybe TeamId+ -> ChannelId+ -> Messages+ -> IO ChannelMessageInterface+newChannelMessageInterface checker eventQueue tId cId msgs = do+ es <- emptyEditStateForChannel checker eventQueue tId cId+ return $ newMessageInterface cId () msgs es (MIChannel cId) (FromChannel cId)++newMessageInterface :: ChannelId+ -> i+ -> Messages+ -> EditState Name+ -> MessageInterfaceTarget+ -> URLListSource+ -> MessageInterface Name i+newMessageInterface cId pId msgs es target src =+ let urlListName = UrlList eName+ eName = getName $ es^.esEditor+ in MessageInterface { _miMessages = msgs+ , _miRootPostId = pId+ , _miChannelId = cId+ , _miMessageSelect = MessageSelectState Nothing+ , _miMode = Compose+ , _miEditor = es+ , _miTarget = target+ , _miUrlListSource = src+ , _miUrlList = URLList { _ulList = list urlListName mempty 2+ , _ulSource = Nothing+ }+ , _miSaveAttachmentDialog = newSaveAttachmentDialog eName "(unused)"+ }++newTeamState :: Config+ -> Team+ -> Z.Zipper ChannelListGroup ChannelListEntry+ -> TeamState+newTeamState config team chanList =+ let tId = teamId team+ in TeamState { _tsModeStack = newStack Main+ , _tsFocus = chanList+ , _tsTeam = team+ , _tsPostListWindow = PostListWindowState emptyDirSeq Nothing+ , _tsUserListWindow = nullUserListWindowState tId+ , _tsChannelListWindow = nullChannelListWindowState tId+ , _tsChannelSelectState = emptyChannelSelectState tId+ , _tsChannelTopicDialog = newChannelTopicDialog tId ""+ , _tsNotifyPrefs = Nothing+ , _tsPendingChannelChange = Nothing+ , _tsRecentChannel = Nothing+ , _tsReturnChannel = Nothing+ , _tsViewedMessage = Nothing+ , _tsThemeListWindow = nullThemeListWindowState tId+ , _tsReactionEmojiListWindow = nullEmojiListWindowState tId+ , _tsChannelListSorting = configChannelListSorting config+ , _tsThreadInterface = Nothing+ , _tsMessageInterfaceFocus = FocusCurrentChannel+ }++nullChannelListWindowState :: TeamId -> ListWindowState Channel ChannelSearchScope+nullChannelListWindowState tId =+ let newList rs = list (JoinChannelList tId) rs 2+ in ListWindowState { _listWindowSearchResults = newList mempty+ , _listWindowSearchInput = editor (JoinChannelListSearchInput tId) (Just 1) ""+ , _listWindowSearchScope = AllChannels+ , _listWindowSearching = False+ , _listWindowEnterHandler = const $ return False+ , _listWindowNewList = newList+ , _listWindowFetchResults = const $ const $ const $ return mempty+ , _listWindowRecordCount = Nothing+ }++nullThemeListWindowState :: TeamId -> ListWindowState InternalTheme ()+nullThemeListWindowState tId =+ let newList rs = list (ThemeListSearchResults tId) rs 3+ in ListWindowState { _listWindowSearchResults = newList mempty+ , _listWindowSearchInput = editor (ThemeListSearchInput tId) (Just 1) ""+ , _listWindowSearchScope = ()+ , _listWindowSearching = False+ , _listWindowEnterHandler = const $ return False+ , _listWindowNewList = newList+ , _listWindowFetchResults = const $ const $ const $ return mempty+ , _listWindowRecordCount = Nothing+ }++nullUserListWindowState :: TeamId -> ListWindowState UserInfo UserSearchScope+nullUserListWindowState tId =+ let newList rs = list (UserListSearchResults tId) rs 1+ in ListWindowState { _listWindowSearchResults = newList mempty+ , _listWindowSearchInput = editor (UserListSearchInput tId) (Just 1) ""+ , _listWindowSearchScope = AllUsers Nothing+ , _listWindowSearching = False+ , _listWindowEnterHandler = const $ return False+ , _listWindowNewList = newList+ , _listWindowFetchResults = const $ const $ const $ return mempty+ , _listWindowRecordCount = Nothing+ }++nullEmojiListWindowState :: TeamId -> ListWindowState (Bool, T.Text) ()+nullEmojiListWindowState tId =+ let newList rs = list (ReactionEmojiList tId) rs 1+ in ListWindowState { _listWindowSearchResults = newList mempty+ , _listWindowSearchInput = editor (ReactionEmojiListInput tId) (Just 1) ""+ , _listWindowSearchScope = ()+ , _listWindowSearching = False+ , _listWindowEnterHandler = const $ return False+ , _listWindowNewList = newList+ , _listWindowFetchResults = const $ const $ const $ return mempty+ , _listWindowRecordCount = Nothing+ }++-- | Make a new channel topic editor window state.+newChannelTopicDialog :: TeamId -> T.Text -> ChannelTopicDialogState+newChannelTopicDialog tId t =+ ChannelTopicDialogState { _channelTopicDialogEditor = editor (ChannelTopicEditor tId) Nothing t+ , _channelTopicDialogFocus = focusRing [ ChannelTopicEditor tId+ , ChannelTopicSaveButton tId+ , ChannelTopicCancelButton tId+ ]+ }++-- | Make a new attachment-saving editor window state.+newSaveAttachmentDialog :: Name -> T.Text -> SaveAttachmentDialogState Name+newSaveAttachmentDialog n t =+ SaveAttachmentDialogState { _attachmentPathEditor = applyEdit Z2.gotoEOL $+ editor (AttachmentPathEditor n) (Just 1) t+ , _attachmentPathDialogFocus = focusRing [ AttachmentPathEditor n+ , AttachmentPathSaveButton n+ , AttachmentPathCancelButton n+ ]+ }++makeClientChannel :: (MonadIO m)+ => BCH.BChan MHEvent+ -> Maybe Aspell+ -> UserId+ -> Maybe TeamId+ -> Channel+ -> m ClientChannel+makeClientChannel eventQueue spellChecker myId tId nc = do+ msgs <- emptyChannelMessages+ mi <- liftIO $ newChannelMessageInterface spellChecker eventQueue tId (getId nc) msgs+ return ClientChannel { _ccInfo = initialChannelInfo myId nc+ , _ccMessageInterface = mi+ }++initialChannelInfo :: UserId -> Channel -> ChannelInfo+initialChannelInfo myId chan =+ let updated = chan ^. channelLastPostAtL+ in ChannelInfo { _cdChannelId = chan^.channelIdL+ , _cdTeamId = chan^.channelTeamIdL+ , _cdViewed = Nothing+ , _cdNewMessageIndicator = Hide+ , _cdEditedMessageThreshold = Nothing+ , _cdMentionCount = 0+ , _cdUpdated = updated+ , _cdName = preferredChannelName chan+ , _cdDisplayName = sanitizeUserText $ channelDisplayName chan+ , _cdHeader = sanitizeUserText $ chan^.channelHeaderL+ , _cdPurpose = sanitizeUserText $ chan^.channelPurposeL+ , _cdType = chan^.channelTypeL+ , _cdNotifyProps = emptyChannelNotifyProps+ , _cdDMUserId = if chan^.channelTypeL == Direct+ then userIdForDMChannel myId $+ sanitizeUserText $ channelName chan+ else Nothing+ , _cdSidebarShowOverride = Nothing+ , _cdFetchPending = False+ }
+ src/Matterhorn/State/Teams.hs-boot view
@@ -0,0 +1,14 @@+module Matterhorn.State.Teams where++import Prelude ()+import Matterhorn.Prelude++import qualified Brick.BChan as BCH+import Text.Aspell ( Aspell )++import Network.Mattermost.Types ( Channel, UserId, TeamId )++import Matterhorn.Types ( MHEvent )+import Matterhorn.Types.Channels ( ClientChannel )++makeClientChannel :: (MonadIO m) => BCH.BChan MHEvent -> Maybe Aspell -> UserId -> Maybe TeamId -> Channel -> m ClientChannel
− src/Matterhorn/State/ThemeListOverlay.hs
@@ -1,87 +0,0 @@-module Matterhorn.State.ThemeListOverlay- ( enterThemeListMode-- , themeListSelectDown- , themeListSelectUp- , themeListPageDown- , themeListPageUp-- , setTheme- )-where--import Prelude ()-import Matterhorn.Prelude--import Brick ( invalidateCache )-import Brick.Themes ( themeToAttrMap )-import qualified Brick.Widgets.List as L-import qualified Data.Text as T-import qualified Data.Vector as Vec-import Lens.Micro.Platform ( (.=) )--import Network.Mattermost.Types--import Matterhorn.State.ListOverlay-import Matterhorn.Themes-import Matterhorn.Types----- | Show the user list overlay with the given search scope, and issue a--- request to gather the first search results.-enterThemeListMode :: TeamId -> MH ()-enterThemeListMode tId =- enterListOverlayMode tId (csTeam(tId).tsThemeListOverlay)- ThemeListOverlay () (setInternalTheme tId) getThemesMatching---- | Move the selection up in the user list overlay by one user.-themeListSelectUp :: TeamId -> MH ()-themeListSelectUp tId = themeListMove tId L.listMoveUp---- | Move the selection down in the user list overlay by one user.-themeListSelectDown :: TeamId -> MH ()-themeListSelectDown tId = themeListMove tId L.listMoveDown---- | Move the selection up in the user list overlay by a page of users--- (themeListPageSize).-themeListPageUp :: TeamId -> MH ()-themeListPageUp tId = themeListMove tId (L.listMoveBy (-1 * themeListPageSize))---- | Move the selection down in the user list overlay by a page of users--- (themeListPageSize).-themeListPageDown :: TeamId -> MH ()-themeListPageDown tId = themeListMove tId (L.listMoveBy themeListPageSize)---- | Transform the user list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-themeListMove :: TeamId -> (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH ()-themeListMove tId = listOverlayMove (csTeam(tId).tsThemeListOverlay)---- | The number of users in a "page" for cursor movement purposes.-themeListPageSize :: Int-themeListPageSize = 10--getThemesMatching :: ()- -> Session- -> Text- -> IO (Vec.Vector InternalTheme)-getThemesMatching _ _ searchString = do- let matching = filter matches internalThemes- search = T.toLower searchString- matches t = search `T.isInfixOf` T.toLower (internalThemeName t) ||- search `T.isInfixOf` T.toLower (internalThemeDesc t)- return $ Vec.fromList matching--setInternalTheme :: TeamId -> InternalTheme -> MH Bool-setInternalTheme tId t = do- setTheme tId $ internalThemeName t- return False--setTheme :: TeamId -> Text -> MH ()-setTheme tId name =- case lookupTheme name of- Nothing -> enterThemeListMode tId- Just it -> do- mh invalidateCache- csResources.crTheme .= (themeToAttrMap $ internalTheme it)
+ src/Matterhorn/State/ThemeListWindow.hs view
@@ -0,0 +1,87 @@+module Matterhorn.State.ThemeListWindow+ ( enterThemeListMode++ , themeListSelectDown+ , themeListSelectUp+ , themeListPageDown+ , themeListPageUp++ , setTheme+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick ( invalidateCache )+import Brick.Themes ( themeToAttrMap )+import qualified Brick.Widgets.List as L+import qualified Data.Text as T+import qualified Data.Vector as Vec+import Lens.Micro.Platform ( (.=) )++import Network.Mattermost.Types++import Matterhorn.State.ListWindow+import Matterhorn.Themes+import Matterhorn.Types+++-- | Show the user list window with the given search scope, and issue a+-- request to gather the first search results.+enterThemeListMode :: TeamId -> MH ()+enterThemeListMode tId =+ enterListWindowMode tId (csTeam(tId).tsThemeListWindow)+ ThemeListWindow () (setInternalTheme tId) getThemesMatching++-- | Move the selection up in the user list window by one user.+themeListSelectUp :: TeamId -> MH ()+themeListSelectUp tId = themeListMove tId L.listMoveUp++-- | Move the selection down in the user list window by one user.+themeListSelectDown :: TeamId -> MH ()+themeListSelectDown tId = themeListMove tId L.listMoveDown++-- | Move the selection up in the user list window by a page of users+-- (themeListPageSize).+themeListPageUp :: TeamId -> MH ()+themeListPageUp tId = themeListMove tId (L.listMoveBy (-1 * themeListPageSize))++-- | Move the selection down in the user list window by a page of users+-- (themeListPageSize).+themeListPageDown :: TeamId -> MH ()+themeListPageDown tId = themeListMove tId (L.listMoveBy themeListPageSize)++-- | Transform the user list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+themeListMove :: TeamId -> (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH ()+themeListMove tId = listWindowMove (csTeam(tId).tsThemeListWindow)++-- | The number of users in a "page" for cursor movement purposes.+themeListPageSize :: Int+themeListPageSize = 10++getThemesMatching :: ()+ -> Session+ -> Text+ -> IO (Vec.Vector InternalTheme)+getThemesMatching _ _ searchString = do+ let matching = filter matches internalThemes+ search = T.toLower searchString+ matches t = search `T.isInfixOf` T.toLower (internalThemeName t) ||+ search `T.isInfixOf` T.toLower (internalThemeDesc t)+ return $ Vec.fromList matching++setInternalTheme :: TeamId -> InternalTheme -> MH Bool+setInternalTheme tId t = do+ setTheme tId $ internalThemeName t+ return False++setTheme :: TeamId -> Text -> MH ()+setTheme tId name =+ case lookupTheme name of+ Nothing -> enterThemeListMode tId+ Just it -> do+ mh invalidateCache+ csResources.crTheme .= (themeToAttrMap $ internalTheme it)
+ src/Matterhorn/State/ThreadWindow.hs view
@@ -0,0 +1,64 @@+module Matterhorn.State.ThreadWindow+ ( openThreadWindow+ , closeThreadWindow+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Data.HashMap.Strict as HM+import Lens.Micro.Platform ( (.=), _Just )++import Network.Mattermost.Types (TeamId, PostId, ChannelId)+import qualified Network.Mattermost.Types as MM+import qualified Network.Mattermost.Endpoints as MM+import Network.Mattermost.Lenses++import Matterhorn.Types+import Matterhorn.State.Common+import Matterhorn.State.Teams ( newThreadInterface )+import {-# SOURCE #-} Matterhorn.State.Messages++openThreadWindow :: TeamId -> ChannelId -> PostId -> MH ()+openThreadWindow tId cId pId = do+ -- If the thread we're switching to is the one we're already+ -- viewing, do nothing.+ mPid <- preuse (maybeThreadInterface(tId)._Just.miRootPostId)+ when (not (mPid == Just pId)) $ do+ -- Fetch the entire thread associated with the post.+ doAsyncMM Preempt getThread processThread+ where getThread session = MM.mmGetThread pId session+ processThread posts = Just $ do+ let numPosts = HM.size (MM.postsPosts posts)++ when (numPosts > 0) $ do+ eventQueue <- use (csResources.crEventQueue)+ msgs <- installMessagesFromPosts (Just tId) posts++ mapM_ (addMessageToState False False . OldPost)+ [ (posts^.postsPostsL) HM.! p+ | p <- toList (posts^.postsOrderL)+ ]++ st <- use id+ case getMessageForPostId st pId of+ Just rootMsg | Just rootPost <- rootMsg^.mOriginalPost -> do+ checker <- use (csResources.crSpellChecker)+ ti <- liftIO $ newThreadInterface checker eventQueue tId cId rootMsg rootPost msgs+ csTeam(tId).tsThreadInterface .= Just ti+ csTeam(tId).tsMessageInterfaceFocus .= FocusThread+ mcId <- use (csCurrentChannelId(tId))+ case mcId of+ Just curId -> invalidateChannelRenderingCache curId+ Nothing -> return ()+ _ -> error "BUG: openThreadWindow failed to find the root message"++closeThreadWindow :: TeamId -> MH ()+closeThreadWindow tId = do+ csTeam(tId).tsThreadInterface .= Nothing+ csTeam(tId).tsMessageInterfaceFocus .= FocusCurrentChannel+ mcId <- use (csCurrentChannelId(tId))+ case mcId of+ Just curId -> invalidateChannelRenderingCache curId+ Nothing -> return ()
+ src/Matterhorn/State/ThreadWindow.hs-boot view
@@ -0,0 +1,14 @@+module Matterhorn.State.ThreadWindow+ ( closeThreadWindow+ , openThreadWindow+ )+where++import Prelude ()++import Network.Mattermost.Types (TeamId, PostId, ChannelId)++import Matterhorn.Types++openThreadWindow :: TeamId -> ChannelId -> PostId -> MH ()+closeThreadWindow :: TeamId -> MH ()
src/Matterhorn/State/UrlSelect.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} module Matterhorn.State.UrlSelect ( -- * URL selection mode@@ -10,40 +11,42 @@ import Prelude () import Matterhorn.Prelude -import Brick.Widgets.List ( list, listMoveTo, listSelectedElement )+import Brick.Widgets.List ( listSelectedElement, listReplace ) import qualified Data.Vector as V-import Lens.Micro.Platform ( (.=), to )--import Network.Mattermost.Types ( TeamId )+import Lens.Micro.Platform ( (.=), (%=), to, Lens' ) import Matterhorn.State.Links import Matterhorn.Types import Matterhorn.Util -startUrlSelect :: TeamId -> MH ()-startUrlSelect tId = do- withCurrentChannel tId $ \_ chan -> do- let urls = V.fromList $ findUrls chan- urlsWithIndexes = V.indexed urls- setMode tId UrlSelect- csTeam(tId).tsUrlList .= (listMoveTo (length urls - 1) $ list (UrlList tId) urlsWithIndexes 2)+startUrlSelect :: Lens' ChatState (MessageInterface n i)+ -> MH ()+startUrlSelect which = do+ msgs <- use (which.miMessages)+ src <- use (which.miUrlListSource)+ let urls = V.fromList $ findUrls msgs+ urlsWithIndexes = V.indexed urls+ which.miMode .= ShowUrlList+ which.miUrlList.ulList %= listReplace urlsWithIndexes (Just $ length urls - 1)+ which.miUrlList.ulSource .= Just src -stopUrlSelect :: TeamId -> MH ()-stopUrlSelect tId = do- setMode tId Main+stopUrlSelect :: Lens' ChatState (MessageInterface n i)+ -> MH ()+stopUrlSelect which = do+ which.miMode .= Compose -openSelectedURL :: TeamId -> MH ()-openSelectedURL tId = whenMode tId UrlSelect $ do- selected <- use (csTeam(tId).tsUrlList.to listSelectedElement)+openSelectedURL :: Lens' ChatState (MessageInterface n i) -> MH ()+openSelectedURL which = do+ selected <- use (which.miUrlList.ulList.to listSelectedElement) case selected of Nothing -> return () Just (_, (_, link)) -> openLinkTarget (link^.linkTarget)- setMode tId Main+ stopUrlSelect which -findUrls :: ClientChannel -> [LinkChoice]-findUrls chan =- let msgs = filterMessages (not . _mDeleted) $ chan^.ccContents.cdMessages+findUrls :: Messages -> [LinkChoice]+findUrls ms =+ let msgs = filterMessages (not . _mDeleted) ms in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs removeDuplicates :: [LinkChoice] -> [LinkChoice]
− src/Matterhorn/State/UserListOverlay.hs
@@ -1,171 +0,0 @@-module Matterhorn.State.UserListOverlay- ( enterChannelMembersUserList- , enterChannelInviteUserList- , enterDMSearchUserList-- , userListSelectDown- , userListSelectUp- , userListPageDown- , userListPageUp- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Brick.Widgets.List as L-import qualified Data.HashMap.Strict as HM-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import qualified Data.Vector as Vec-import Lens.Micro.Platform ( (.~), (.=) )--import qualified Network.Mattermost.Endpoints as MM-import qualified Network.Mattermost.Types.Config as MM-import Network.Mattermost.Types--import Matterhorn.State.Async ( doAsyncWith, AsyncPriority(Preempt) )-import Matterhorn.State.Channels ( createOrFocusDMChannel, addUserToCurrentChannel )-import Matterhorn.State.ListOverlay-import Matterhorn.Types----- | Show the user list overlay for searching/showing members of the--- current channel.-enterChannelMembersUserList :: TeamId -> MH ()-enterChannelMembersUserList myTId = do- withCurrentChannel myTId $ \cId _ -> do- myId <- gets myUserId- session <- getSession-- doAsyncWith Preempt $ do- stats <- MM.mmGetChannelStatistics cId session- return $ Just $ do- enterUserListMode myTId (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats)- (\u -> case u^.uiId /= myId of- True -> createOrFocusDMChannel myTId u Nothing >> return True- False -> return False- )---- | Show the user list overlay for showing users that are not members--- of the current channel for the purpose of adding them to the--- channel.-enterChannelInviteUserList :: TeamId -> MH ()-enterChannelInviteUserList myTId = do- withCurrentChannel myTId $ \cId _ -> do- myId <- gets myUserId- enterUserListMode myTId (ChannelNonMembers cId myTId) Nothing- (\u -> case u^.uiId /= myId of- True -> addUserToCurrentChannel myTId u >> return True- False -> return False- )---- | Show the user list overlay for showing all users for the purpose of--- starting a direct message channel with another user.-enterDMSearchUserList :: TeamId -> MH ()-enterDMSearchUserList myTId = do- myId <- gets myUserId- config <- use csClientConfig- let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of- Just MM.RestrictTeam -> Just myTId- _ -> Nothing- enterUserListMode myTId (AllUsers restrictTeam) Nothing- (\u -> case u^.uiId /= myId of- True -> createOrFocusDMChannel myTId u Nothing >> return True- False -> return False- )---- | Show the user list overlay with the given search scope, and issue a--- request to gather the first search results.-enterUserListMode :: TeamId -> UserSearchScope -> Maybe Int -> (UserInfo -> MH Bool) -> MH ()-enterUserListMode tId scope resultCount enterHandler = do- csTeam(tId).tsUserListOverlay.listOverlayRecordCount .= resultCount- enterListOverlayMode tId (csTeam(tId).tsUserListOverlay) UserListOverlay scope enterHandler getUserSearchResults--userInfoFromPair :: User -> Text -> UserInfo-userInfoFromPair u status =- userInfoFromUser u True & uiStatus .~ statusFromText status---- | Move the selection up in the user list overlay by one user.-userListSelectUp :: TeamId -> MH ()-userListSelectUp tId = userListMove tId L.listMoveUp---- | Move the selection down in the user list overlay by one user.-userListSelectDown :: TeamId -> MH ()-userListSelectDown tId = userListMove tId L.listMoveDown---- | Move the selection up in the user list overlay by a page of users--- (userListPageSize).-userListPageUp :: TeamId -> MH ()-userListPageUp tId = userListMove tId (L.listMoveBy (-1 * userListPageSize))---- | Move the selection down in the user list overlay by a page of users--- (userListPageSize).-userListPageDown :: TeamId -> MH ()-userListPageDown tId = userListMove tId (L.listMoveBy userListPageSize)---- | Transform the user list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-userListMove :: TeamId -> (L.List Name UserInfo -> L.List Name UserInfo) -> MH ()-userListMove tId = listOverlayMove (csTeam(tId).tsUserListOverlay)---- | The number of users in a "page" for cursor movement purposes.-userListPageSize :: Int-userListPageSize = 10--getUserSearchResults :: UserSearchScope- -- ^ The scope to search- -> Session- -- ^ The connection session- -> Text- -- ^ The search string- -> IO (Vec.Vector UserInfo)-getUserSearchResults scope s searchString = do- -- Unfortunately, we don't get pagination control when there is a- -- search string in effect. We'll get at most 100 results from a- -- search.- let query = UserSearch { userSearchTerm = if T.null searchString then " " else searchString- -- Hack alert: Searching with the string " "- -- above is a hack to use the search- -- endpoint to get "all users" instead of- -- those matching a particular non-empty- -- non-whitespace string. This is because- -- only the search endpoint provides a- -- control to eliminate deleted users from- -- the results. If we don't do this, and- -- use the /users endpoint instead, we'll- -- get deleted users in those results and- -- then those deleted users will disappear- -- from the results once the user enters a- -- non-empty string string.- , userSearchAllowInactive = False- , userSearchWithoutTeam = False- , userSearchInChannelId = case scope of- ChannelMembers cId _ -> Just cId- _ -> Nothing- , userSearchNotInTeamId = Nothing- , userSearchNotInChannelId = case scope of- ChannelNonMembers cId _ -> Just cId- _ -> Nothing- , userSearchTeamId = case scope of- AllUsers tId -> tId- ChannelMembers _ tId -> Just tId- ChannelNonMembers _ tId -> Just tId- }- users <- MM.mmSearchUsers query s-- let uList = toList users- uIds = userId <$> uList-- -- Now fetch status info for the users we got.- case null uList of- False -> do- statuses <- MM.mmGetUserStatusByIds (Seq.fromList uIds) s- let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- toList statuses ]- usersWithStatus = [ userInfoFromPair u (fromMaybe "" $ HM.lookup (userId u) statusMap)- | u <- uList- ]-- return $ Vec.fromList usersWithStatus- True -> return mempty
+ src/Matterhorn/State/UserListWindow.hs view
@@ -0,0 +1,171 @@+module Matterhorn.State.UserListWindow+ ( enterChannelMembersUserList+ , enterChannelInviteUserList+ , enterDMSearchUserList++ , userListSelectDown+ , userListSelectUp+ , userListPageDown+ , userListPageUp+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Data.HashMap.Strict as HM+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Vector as Vec+import Lens.Micro.Platform ( (.~), (.=) )++import qualified Network.Mattermost.Endpoints as MM+import qualified Network.Mattermost.Types.Config as MM+import Network.Mattermost.Types++import Matterhorn.State.Async ( doAsyncWith, AsyncPriority(Preempt) )+import Matterhorn.State.Channels ( createOrFocusDMChannel, addUserToCurrentChannel )+import Matterhorn.State.ListWindow+import Matterhorn.Types+++-- | Show the user list window for searching/showing members of the+-- current channel.+enterChannelMembersUserList :: TeamId -> MH ()+enterChannelMembersUserList myTId = do+ withCurrentChannel myTId $ \cId _ -> do+ myId <- gets myUserId+ session <- getSession++ doAsyncWith Preempt $ do+ stats <- MM.mmGetChannelStatistics cId session+ return $ Just $ do+ enterUserListMode myTId (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats)+ (\u -> case u^.uiId /= myId of+ True -> createOrFocusDMChannel myTId u Nothing >> return True+ False -> return False+ )++-- | Show the user list window for showing users that are not members+-- of the current channel for the purpose of adding them to the+-- channel.+enterChannelInviteUserList :: TeamId -> MH ()+enterChannelInviteUserList myTId = do+ withCurrentChannel myTId $ \cId _ -> do+ myId <- gets myUserId+ enterUserListMode myTId (ChannelNonMembers cId myTId) Nothing+ (\u -> case u^.uiId /= myId of+ True -> addUserToCurrentChannel myTId u >> return True+ False -> return False+ )++-- | Show the user list window for showing all users for the purpose of+-- starting a direct message channel with another user.+enterDMSearchUserList :: TeamId -> MH ()+enterDMSearchUserList myTId = do+ myId <- gets myUserId+ config <- use csClientConfig+ let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of+ Just MM.RestrictTeam -> Just myTId+ _ -> Nothing+ enterUserListMode myTId (AllUsers restrictTeam) Nothing+ (\u -> case u^.uiId /= myId of+ True -> createOrFocusDMChannel myTId u Nothing >> return True+ False -> return False+ )++-- | Show the user list window with the given search scope, and issue a+-- request to gather the first search results.+enterUserListMode :: TeamId -> UserSearchScope -> Maybe Int -> (UserInfo -> MH Bool) -> MH ()+enterUserListMode tId scope resultCount enterHandler = do+ csTeam(tId).tsUserListWindow.listWindowRecordCount .= resultCount+ enterListWindowMode tId (csTeam(tId).tsUserListWindow) UserListWindow scope enterHandler getUserSearchResults++userInfoFromPair :: User -> Text -> UserInfo+userInfoFromPair u status =+ userInfoFromUser u True & uiStatus .~ statusFromText status++-- | Move the selection up in the user list window by one user.+userListSelectUp :: TeamId -> MH ()+userListSelectUp tId = userListMove tId L.listMoveUp++-- | Move the selection down in the user list window by one user.+userListSelectDown :: TeamId -> MH ()+userListSelectDown tId = userListMove tId L.listMoveDown++-- | Move the selection up in the user list window by a page of users+-- (userListPageSize).+userListPageUp :: TeamId -> MH ()+userListPageUp tId = userListMove tId (L.listMoveBy (-1 * userListPageSize))++-- | Move the selection down in the user list window by a page of users+-- (userListPageSize).+userListPageDown :: TeamId -> MH ()+userListPageDown tId = userListMove tId (L.listMoveBy userListPageSize)++-- | Transform the user list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+userListMove :: TeamId -> (L.List Name UserInfo -> L.List Name UserInfo) -> MH ()+userListMove tId = listWindowMove (csTeam(tId).tsUserListWindow)++-- | The number of users in a "page" for cursor movement purposes.+userListPageSize :: Int+userListPageSize = 10++getUserSearchResults :: UserSearchScope+ -- ^ The scope to search+ -> Session+ -- ^ The connection session+ -> Text+ -- ^ The search string+ -> IO (Vec.Vector UserInfo)+getUserSearchResults scope s searchString = do+ -- Unfortunately, we don't get pagination control when there is a+ -- search string in effect. We'll get at most 100 results from a+ -- search.+ let query = UserSearch { userSearchTerm = if T.null searchString then " " else searchString+ -- Hack alert: Searching with the string " "+ -- above is a hack to use the search+ -- endpoint to get "all users" instead of+ -- those matching a particular non-empty+ -- non-whitespace string. This is because+ -- only the search endpoint provides a+ -- control to eliminate deleted users from+ -- the results. If we don't do this, and+ -- use the /users endpoint instead, we'll+ -- get deleted users in those results and+ -- then those deleted users will disappear+ -- from the results once the user enters a+ -- non-empty string string.+ , userSearchAllowInactive = False+ , userSearchWithoutTeam = False+ , userSearchInChannelId = case scope of+ ChannelMembers cId _ -> Just cId+ _ -> Nothing+ , userSearchNotInTeamId = Nothing+ , userSearchNotInChannelId = case scope of+ ChannelNonMembers cId _ -> Just cId+ _ -> Nothing+ , userSearchTeamId = case scope of+ AllUsers tId -> tId+ ChannelMembers _ tId -> Just tId+ ChannelNonMembers _ tId -> Just tId+ }+ users <- MM.mmSearchUsers query s++ let uList = toList users+ uIds = userId <$> uList++ -- Now fetch status info for the users we got.+ case null uList of+ False -> do+ statuses <- MM.mmGetUserStatusByIds (Seq.fromList uIds) s+ let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- toList statuses ]+ usersWithStatus = [ userInfoFromPair u (fromMaybe "" $ HM.lookup (userId u) statusMap)+ | u <- uList+ ]++ return $ Vec.fromList usersWithStatus+ True -> return mempty
src/Matterhorn/State/Users.hs view
@@ -13,6 +13,7 @@ import qualified Data.Text as T import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import Data.Time ( getCurrentTime ) import Lens.Micro.Platform@@ -39,13 +40,25 @@ -- | Handle the typing events from the websocket to show the currently -- typing users on UI-handleTypingUser :: UserId -> ChannelId -> MH ()-handleTypingUser uId cId = do+handleTypingUser :: UserId -> ChannelId -> Maybe PostId -> MH ()+handleTypingUser uId cId threadRootPostId = do config <- use (csResources.crConfiguration) when (configShowTypingIndicator config) $ do withFetchedUser (UserFetchById uId) $ const $ do ts <- liftIO getCurrentTime- csChannels %= modifyChannelById cId (addChannelTypingUser uId ts)++ -- Indicate that the user is typing in the specified+ -- channel.+ csChannel(cId).ccMessageInterface.miEditor.esEphemeral %= addEphemeralStateTypingUser uId ts++ -- If the typing is occurring in a thread and that thread is+ -- open in some team, also indicate that the user is typing+ -- in that thread's window.+ teams <- use csTeams+ forM_ (HM.keys teams) $ \tId -> do+ pId <- preuse (threadInterface(tId).miRootPostId)+ when (pId == threadRootPostId) $ do+ threadInterface(tId).miEditor.esEphemeral %= addEphemeralStateTypingUser uId ts -- | Handle the websocket event for when a user is updated, e.g. has changed -- their nickname
src/Matterhorn/Themes.hs view
@@ -37,6 +37,7 @@ , errorMessageAttr , helpAttr , helpEmphAttr+ , helpKeyEventAttr , channelSelectPromptAttr , channelSelectMatchAttr , completionAlternativeListAttr@@ -58,6 +59,8 @@ , tabUnselectedAttr , buttonAttr , buttonFocusedAttr+ , threadAttr+ , focusedEditorPromptAttr -- * Username formatting , colorUsername@@ -94,6 +97,9 @@ helpEmphAttr :: AttrName helpEmphAttr = "helpEmphasis" +helpKeyEventAttr :: AttrName+helpKeyEventAttr = "helpKeyEvent"+ recentMarkerAttr :: AttrName recentMarkerAttr = "recentChannelMarker" @@ -238,6 +244,12 @@ buttonFocusedAttr :: AttrName buttonFocusedAttr = buttonAttr <> "focused" +threadAttr :: AttrName+threadAttr = "thread"++focusedEditorPromptAttr :: AttrName+focusedEditorPromptAttr = "focusedEditorPrompt"+ lookupTheme :: Text -> Maybe InternalTheme lookupTheme n = find ((== n) . internalThemeName) internalThemes @@ -287,6 +299,8 @@ in [ (timeAttr, fg black) , (buttonAttr, black `on` cyan) , (buttonFocusedAttr, black `on` yellow)+ , (threadAttr, defAttr)+ , (focusedEditorPromptAttr, fg yellow `withStyle` bold) , (currentUserAttr, defAttr `withStyle` bold) , (channelHeaderAttr, fg black) , (verbatimTruncateMessageAttr, fg blue)@@ -317,6 +331,7 @@ , (helpAttr, fg black) , (pinnedMessageIndicatorAttr, black `on` cyan) , (helpEmphAttr, fg blue `withStyle` bold)+ , (helpKeyEventAttr, fg magenta) , (channelSelectMatchAttr, black `on` magenta `withStyle` underline) , (channelSelectPromptAttr, fg black) , (completionAlternativeListAttr, white `on` blue)@@ -355,6 +370,8 @@ in [ (timeAttr, fg white) , (buttonAttr, black `on` cyan) , (buttonFocusedAttr, black `on` yellow)+ , (threadAttr, defAttr)+ , (focusedEditorPromptAttr, fg yellow `withStyle` bold) , (currentUserAttr, defAttr `withStyle` bold) , (channelHeaderAttr, fg white) , (verbatimTruncateMessageAttr, fg cyan)@@ -385,6 +402,7 @@ , (gapMessageAttr, black `on` yellow) , (helpAttr, fg white) , (helpEmphAttr, fg cyan `withStyle` bold)+ , (helpKeyEventAttr, fg yellow) , (channelSelectMatchAttr, black `on` magenta `withStyle` underline) , (channelSelectPromptAttr, fg white) , (completionAlternativeListAttr, white `on` blue)@@ -656,6 +674,9 @@ , ( helpEmphAttr , "The help screen's emphasized text" )+ , ( helpKeyEventAttr+ , "The help screen's mention of key event names"+ ) , ( channelSelectPromptAttr , "Channel selection: prompt" )@@ -862,6 +883,12 @@ ) , ( scrollbarHandleAttr , "Attribute for scroll bar handles"+ )+ , ( threadAttr+ , "Base attribute for the thread window"+ )+ , ( focusedEditorPromptAttr+ , "The attribute for the prompt of the focused message editor" ) ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i) | i <- [0..usernameColorHashBuckets-1]
src/Matterhorn/Types.hs view
@@ -5,2606 +5,2168 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-module Matterhorn.Types- ( ConnectionStatus(..)- , HelpTopic(..)- , MessageSelectState(..)- , ProgramOutput(..)- , MHEvent(..)- , InternalEvent(..)- , Name(..)- , ChannelSelectMatch(..)- , StartupStateInfo(..)- , MHError(..)- , AttachmentData(..)- , CPUUsagePolicy(..)- , SemEq(..)- , tabbedWindow- , getCurrentTabbedWindowEntry- , tabbedWindowNextTab- , tabbedWindowPreviousTab- , runTabShowHandlerFor- , getServerBaseUrl- , serverBaseUrl- , TabbedWindow(..)- , TabbedWindowEntry(..)- , TabbedWindowTemplate(..)- , ConnectionInfo(..)- , SidebarUpdate(..)- , PendingChannelChange(..)- , ViewMessageWindowTab(..)- , clearChannelUnreadStatus- , ChannelListEntry(..)- , ChannelListEntryType(..)- , ChannelListSorting(..)- , ChannelListOrientation(..)- , channelListEntryUserId- , userIdsFromZipper- , entryIsDMEntry- , ciHostname- , ciPort- , ciUrlPath- , ciUsername- , ciOTPToken- , ciPassword- , ciType- , ciAccessToken- , newChannelTopicDialog- , ChannelTopicDialogState(..)- , channelTopicDialogEditor- , channelTopicDialogFocus-- , resultToWidget-- , newSaveAttachmentDialog- , SaveAttachmentDialogState(..)- , attachmentPathEditor- , attachmentPathDialogFocus-- , Config(..)- , configUserL- , configHostL- , configTeamL- , configPortL- , configUrlPathL- , configPassL- , configTokenL- , configTimeFormatL- , configDateFormatL- , configThemeL- , configThemeCustomizationFileL- , configSmartBacktickL- , configSmartEditingL- , configURLOpenCommandL- , configURLOpenCommandInteractiveL- , configActivityNotifyCommandL- , configActivityNotifyVersionL- , configActivityBellL- , configTruncateVerbatimBlocksL- , configChannelListSortingL- , configShowMessageTimestampsL- , configShowBackgroundL- , configShowMessagePreviewL- , configShowChannelListL- , configShowExpandedChannelTopicsL- , configEnableAspellL- , configAspellDictionaryL- , configUnsafeUseHTTPL- , configValidateServerCertificateL- , configChannelListWidthL- , configLogMaxBufferSizeL- , configShowOlderEditsL- , configShowTypingIndicatorL- , configSendTypingNotificationsL- , configAbsPathL- , configUserKeysL- , configHyperlinkingModeL- , configSyntaxDirsL- , configDirectChannelExpirationDaysL- , configCpuUsagePolicyL- , configDefaultAttachmentPathL- , configChannelListOrientationL- , configMouseModeL-- , NotificationVersion(..)- , HelpScreen(..)- , PasswordSource(..)- , TokenSource(..)- , MatchType(..)- , Mode(..)- , ChannelSelectPattern(..)- , PostListContents(..)- , AuthenticationException(..)- , BackgroundInfo(..)- , RequestChan- , UserFetch(..)- , writeBChan- , InternalTheme(..)-- , attrNameToConfig-- , sortTeams- , matchesTeam- , mkTeamZipper- , mkTeamZipperFromIds- , teamZipperIds- , mkChannelZipperList- , ChannelListGroup(..)- , ChannelListGroupLabel(..)- , nonDMChannelListGroupUnread- , channelListGroupNames-- , trimChannelSigil-- , ChannelSelectState(..)- , channelSelectMatches- , channelSelectInput- , emptyChannelSelectState-- , TeamState(..)- , tsFocus- , tsMode- , tsPendingChannelChange- , tsRecentChannel- , tsReturnChannel- , tsEditState- , tsMessageSelect- , tsTeam- , tsChannelSelectState- , tsUrlList- , tsViewedMessage- , tsPostListOverlay- , tsUserListOverlay- , tsChannelListOverlay- , tsNotifyPrefs- , tsChannelTopicDialog- , tsReactionEmojiListOverlay- , tsThemeListOverlay- , tsSaveAttachmentDialog- , tsChannelListSorting-- , ChatState- , newState- , newTeamState-- , withCurrentChannel- , withCurrentChannel'- , withCurrentTeam-- , csTeamZipper- , csTeams- , csTeam- , csChannelListOrientation- , csResources- , csLastMouseDownEvent- , csVerbatimTruncateSetting- , csCurrentChannelId- , csCurrentTeamId- , csPostMap- , csUsers- , csHiddenChannelGroups- , csConnectionStatus- , csWorkerIsBusy- , csChannel- , csChannels- , csClientConfig- , csInputHistory- , csMe- , timeZone- , whenMode- , setMode- , setMode'-- , ChatEditState- , emptyEditState- , cedAttachmentList- , cedFileBrowser- , unsafeCedFileBrowser- , cedYankBuffer- , cedSpellChecker- , cedMisspellings- , cedEditMode- , cedEphemeral- , cedEditor- , cedAutocomplete- , cedAutocompletePending- , cedJustCompleted-- , AutocompleteState(..)- , acPreviousSearchString- , acCompletionList- , acCachedResponses- , acType-- , AutocompletionType(..)-- , CompletionSource(..)- , AutocompleteAlternative(..)- , autocompleteAlternativeReplacement- , SpecialMention(..)- , specialMentionName- , isSpecialMention-- , PostListOverlayState- , postListSelected- , postListPosts-- , UserSearchScope(..)- , ChannelSearchScope(..)-- , ListOverlayState- , listOverlaySearchResults- , listOverlaySearchInput- , listOverlaySearchScope- , listOverlaySearching- , listOverlayEnterHandler- , listOverlayNewList- , listOverlayFetchResults- , listOverlayRecordCount- , listOverlayReturnMode-- , getUsers-- , ChatResources(..)- , crUserPreferences- , crEventQueue- , crTheme- , crStatusUpdateChan- , crSubprocessLog- , crWebsocketActionChan- , crWebsocketThreadId- , crRequestQueue- , crFlaggedPosts- , crConn- , crConfiguration- , crSyntaxMap- , crLogManager- , crEmoji- , getSession- , getResourceSession-- , specialUserMentions-- , applyTeamOrder- , refreshTeamZipper-- , UserPreferences(UserPreferences)- , userPrefShowJoinLeave- , userPrefFlaggedPostList- , userPrefGroupChannelPrefs- , userPrefDirectChannelPrefs- , userPrefTeammateNameDisplayMode- , userPrefTeamOrder- , userPrefFavoriteChannelPrefs- , dmChannelShowPreference- , groupChannelShowPreference- , favoriteChannelPreference-- , defaultUserPreferences- , setUserPreferences-- , WebsocketAction(..)-- , Cmd(..)- , commandName- , CmdArgs(..)-- , MH- , runMHEvent- , scheduleUserFetches- , scheduleUserStatusFetches- , getScheduledUserFetches- , getScheduledUserStatusFetches- , mh- , generateUUID- , generateUUID_IO- , mhSuspendAndResume- , mhHandleEventLensed- , mhHandleEventLensed'- , mhContinueWithoutRedraw- , St.gets- , mhError-- , mhLog- , mhGetIOLogger- , ioLogWithManager- , LogContext(..)- , withLogContext- , withLogContextChannelId- , getLogContext- , LogMessage(..)- , LogCommand(..)- , LogCategory(..)-- , LogManager(..)- , startLoggingToFile- , stopLoggingToFile- , requestLogSnapshot- , requestLogDestination- , sendLogMessage-- , requestQuit- , getMessageForPostId- , getParentMessage- , getReplyRootMessage- , resetSpellCheckTimer- , withChannel- , withChannelOrDefault- , userList- , resetAutocomplete- , isMine- , setUserStatus- , myUser- , myUsername- , myUserId- , usernameForUserId- , userByUsername- , userByNickname- , channelIdByChannelName- , channelIdByUsername- , userById- , allUserIds- , addNewUser- , useNickname- , useNickname'- , displayNameForUserId- , displayNameForUser- , raiseInternalEvent- , getNewMessageCutoff- , getEditedMessageCutoff-- , HighlightSet(..)- , UserSet- , ChannelSet- , getHighlightSet- , emptyHSet-- , moveLeft- , moveRight-- , module Matterhorn.Types.Channels- , module Matterhorn.Types.Messages- , module Matterhorn.Types.Posts- , module Matterhorn.Types.Users- )-where--import Prelude ()-import Matterhorn.Prelude--import qualified Graphics.Vty as Vty-import qualified Brick-import Brick ( EventM, Next, Widget(..), Size(..), Result )-import Brick.Focus ( FocusRing, focusRing )-import Brick.Themes ( Theme )-import Brick.Main ( invalidateCache, invalidateCacheEntry )-import Brick.AttrMap ( AttrMap )-import qualified Brick.BChan as BCH-import Brick.Forms (Form)-import Brick.Widgets.Edit ( Editor, editor, applyEdit )-import Brick.Widgets.List ( List, list )-import qualified Brick.Widgets.FileBrowser as FB-import Control.Concurrent ( ThreadId )-import Control.Concurrent.Async ( Async )-import qualified Control.Concurrent.STM as STM-import Control.Exception ( SomeException )-import qualified Control.Monad.Fail as MHF-import qualified Control.Monad.State as St-import qualified Control.Monad.Reader as R-import qualified Data.Set as Set-import qualified Data.ByteString as BS-import qualified Data.Foldable as F-import Data.Function ( on )-import qualified Data.Kind as K-import Data.Maybe ( fromJust )-import Data.Ord ( comparing )-import qualified Data.HashMap.Strict as HM-import Data.List ( sortBy, nub, elemIndex, partition )-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import qualified Data.Text.Zipper as Z2-import Data.Time.Clock ( getCurrentTime, addUTCTime )-import Data.UUID ( UUID )-import qualified Data.Vector as Vec-import Lens.Micro.Platform ( at, makeLenses, lens, (^?!), (.=)- , (%=), (.~), _Just, Traversal', to- , SimpleGetter- )-import Network.Connection ( HostNotResolved, HostCannotConnect )-import Skylighting.Types ( SyntaxMap )-import System.Exit ( ExitCode )-import System.Random ( randomIO )-import Text.Aspell ( Aspell )--import Network.Mattermost ( ConnectionData )-import Network.Mattermost.Exceptions-import Network.Mattermost.Lenses-import Network.Mattermost.Types-import Network.Mattermost.Types.Config-import Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse )--import Matterhorn.Constants ( normalChannelSigil )-import Matterhorn.InputHistory-import Matterhorn.Emoji-import Matterhorn.Types.Common-import Matterhorn.Types.Channels-import Matterhorn.Types.DirectionalSeq ( emptyDirSeq )-import Matterhorn.Types.KeyEvents-import Matterhorn.Types.Messages-import Matterhorn.Types.Posts-import Matterhorn.Types.RichText ( TeamBaseURL(..), TeamURLName(..) )-import Matterhorn.Types.Users-import qualified Matterhorn.Zipper as Z----- * Configuration---- | A notification version for the external notifier-data NotificationVersion =- NotifyV1- | NotifyV2- deriving (Eq, Read, Show)---- | A user password is either given to us directly, or a command--- which we execute to find the password.-data PasswordSource =- PasswordString Text- | PasswordCommand Text- deriving (Eq, Read, Show)---- | An access token source.-data TokenSource =- TokenString Text- | TokenCommand Text- deriving (Eq, Read, Show)---- | The type of channel list group headings. Integer arguments indicate--- total number of channels in the group that have unread activity.-data ChannelListGroup =- ChannelListGroup { channelListGroupLabel :: ChannelListGroupLabel- , channelListGroupUnread :: Int- , channelListGroupCollapsed :: Bool- , channelListGroupEntries :: Int- }- deriving (Eq, Show)--data ChannelListGroupLabel =- ChannelGroupPublicChannels- | ChannelGroupPrivateChannels- | ChannelGroupFavoriteChannels- | ChannelGroupDirectMessages- deriving (Eq, Ord, Show)--channelListGroupNames :: [(T.Text, ChannelListGroupLabel)]-channelListGroupNames =- [ ("public", ChannelGroupPublicChannels)- , ("private", ChannelGroupPrivateChannels)- , ("favorite", ChannelGroupFavoriteChannels)- , ("direct", ChannelGroupDirectMessages)- ]--nonDMChannelListGroupUnread :: ChannelListGroup -> Int-nonDMChannelListGroupUnread g =- case channelListGroupLabel g of- ChannelGroupDirectMessages -> 0- _ -> channelListGroupUnread g---- | The type of channel list entries.-data ChannelListEntry =- ChannelListEntry { channelListEntryChannelId :: ChannelId- , channelListEntryType :: ChannelListEntryType- , channelListEntryUnread :: Bool- , channelListEntrySortValue :: T.Text- , channelListEntryFavorite :: Bool- , channelListEntryMuted :: Bool- }- deriving (Eq, Show, Ord)--data ChannelListEntryType =- CLChannel- -- ^ A non-DM entry- | CLUserDM UserId- -- ^ A single-user DM entry- | CLGroupDM- -- ^ A multi-user DM entry- deriving (Eq, Show, Ord)--data ChannelListSorting =- ChannelListSortDefault- | ChannelListSortUnreadFirst- deriving (Eq, Show, Ord)---- | This is how we represent the user's configuration. Most fields--- correspond to configuration file settings (see Config.hs) but some--- are for internal book-keeping purposes only.-data Config =- Config { configUser :: Maybe Text- -- ^ The username to use when connecting.- , configHost :: Maybe Text- -- ^ The hostname to use when connecting.- , configTeam :: Maybe Text- -- ^ The team name to use when connecting.- , configPort :: Int- -- ^ The port to use when connecting.- , configUrlPath :: Maybe Text- -- ^ The server path to use when connecting.- , configPass :: Maybe PasswordSource- -- ^ The password source to use when connecting.- , configToken :: Maybe TokenSource- -- ^ The token source to use when connecting.- , configTimeFormat :: Maybe Text- -- ^ The format string for timestamps.- , configDateFormat :: Maybe Text- -- ^ The format string for dates.- , configTheme :: Maybe Text- -- ^ The name of the theme to use.- , configThemeCustomizationFile :: Maybe Text- -- ^ The path to the theme customization file, if any.- , configSmartBacktick :: Bool- -- ^ Whether to enable smart quoting characters.- , configSmartEditing :: Bool- -- ^ Whether to enable smart editing behaviors.- , configURLOpenCommand :: Maybe Text- -- ^ The command to use to open URLs.- , configURLOpenCommandInteractive :: Bool- -- ^ Whether the URL-opening command is interactive (i.e.- -- whether it should be given control of the terminal).- , configActivityNotifyCommand :: Maybe T.Text- -- ^ The command to run for activity notifications.- , configActivityNotifyVersion :: NotificationVersion- -- ^ The activity notifier version.- , configActivityBell :: Bool- -- ^ Whether to ring the terminal bell on activity.- , configTruncateVerbatimBlocks :: Maybe Int- -- ^ Whether to truncate verbatim (and code) blocks past a- -- reasonable number of lines.- , configShowMessageTimestamps :: Bool- -- ^ Whether to show timestamps on messages.- , configShowBackground :: BackgroundInfo- -- ^ Whether to show async background worker thread info.- , configShowMessagePreview :: Bool- -- ^ Whether to show the message preview area.- , configShowChannelList :: Bool- -- ^ Whether to show the channel list.- , configShowExpandedChannelTopics :: Bool- -- ^ Whether to show expanded channel topics.- , configEnableAspell :: Bool- -- ^ Whether to enable Aspell spell checking.- , configAspellDictionary :: Maybe Text- -- ^ A specific Aspell dictionary name to use.- , configUnsafeUseHTTP :: Bool- -- ^ Whether to permit an insecure HTTP connection.- , configValidateServerCertificate :: Bool- -- ^ Whether to validate TLS certificates.- , configChannelListWidth :: Int- -- ^ The width, in columns, of the channel list sidebar.- , configLogMaxBufferSize :: Int- -- ^ The maximum size, in log entries, of the internal log- -- message buffer.- , configShowOlderEdits :: Bool- -- ^ Whether to highlight the edit indicator on edits made- -- prior to the beginning of the current session.- , configChannelListSorting :: ChannelListSorting- -- ^ How to sort channels in each channel list group- , configShowTypingIndicator :: Bool- -- ^ Whether to show the typing indicator when other users- -- are typing- , configSendTypingNotifications :: Bool- -- Whether to send typing notifications to other users.- , configAbsPath :: Maybe FilePath- -- ^ A book-keeping field for the absolute path to the- -- configuration. (Not a user setting.)- , configUserKeys :: KeyConfig- -- ^ The user's keybinding configuration.- , configHyperlinkingMode :: Bool- -- ^ Whether to enable terminal hyperlinking mode.- , configSyntaxDirs :: [FilePath]- -- ^ The search path for syntax description XML files.- , configDirectChannelExpirationDays :: Int- -- ^ The number of days to show a user in the channel menu after a direct- -- message with them.- , configCpuUsagePolicy :: CPUUsagePolicy- -- ^ The CPU usage policy for the application.- , configDefaultAttachmentPath :: Maybe FilePath- -- ^ The default path for browsing attachments- , configChannelListOrientation :: ChannelListOrientation- -- ^ The orientation of the channel list.- , configMouseMode :: Bool- -- ^ Whether to enable mouse support in matterhorn- } deriving (Eq, Show)---- | The policy for CPU usage.------ The idea is that Matterhorn can benefit from using multiple CPUs,--- but the exact number is application-determined. We expose this policy--- setting to the user in the configuration.-data CPUUsagePolicy =- SingleCPU- -- ^ Constrain the application to use one CPU.- | MultipleCPUs- -- ^ Permit the usage of multiple CPUs (the exact number is- -- determined by the application).- deriving (Eq, Show)---- | The state of the UI diagnostic indicator for the async worker--- thread.-data BackgroundInfo =- Disabled- -- ^ Disable (do not show) the indicator.- | Active- -- ^ Show the indicator when the thread is working.- | ActiveCount- -- ^ Show the indicator when the thread is working, but include the- -- thread's work queue length.- deriving (Eq, Show)--data UserPreferences =- UserPreferences { _userPrefShowJoinLeave :: Bool- , _userPrefFlaggedPostList :: Seq FlaggedPost- , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool- , _userPrefDirectChannelPrefs :: HashMap UserId Bool- , _userPrefFavoriteChannelPrefs :: HashMap ChannelId Bool- , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode- , _userPrefTeamOrder :: Maybe [TeamId]- }--hasUnread' :: ClientChannel -> Bool-hasUnread' chan = fromMaybe False $ do- let info = _ccInfo chan- lastViewTime <- _cdViewed info- return $ _cdMentionCount info > 0 ||- (not (isMuted chan) &&- (((_cdUpdated info) > lastViewTime) ||- (isJust $ _cdEditedMessageThreshold info)))--mkChannelZipperList :: ChannelListSorting- -> UTCTime- -> Config- -> TeamId- -> Maybe ClientConfig- -> UserPreferences- -> HM.HashMap TeamId (Set ChannelListGroupLabel)- -> ClientChannels- -> Users- -> [(ChannelListGroup, [ChannelListEntry])]-mkChannelZipperList sorting now config tId cconfig prefs hidden cs us =- let (privFavs, privEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Private- (normFavs, normEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Ordinary- (dmFavs, dmEntries) = partitionFavorites $ getDMChannelEntries now config cconfig prefs us cs- favEntries = privFavs <> normFavs <> dmFavs- isHidden label =- case HM.lookup tId hidden of- Nothing -> False- Just s -> Set.member label s- in [ let unread = length $ filter channelListEntryUnread favEntries- coll = isHidden ChannelGroupFavoriteChannels- in ( ChannelListGroup ChannelGroupFavoriteChannels unread coll (length favEntries)- , if coll then mempty else sortChannelListEntries sorting favEntries- )- , let unread = length $ filter channelListEntryUnread normEntries- coll = isHidden ChannelGroupPublicChannels- in ( ChannelListGroup ChannelGroupPublicChannels unread coll (length normEntries)- , if coll then mempty else sortChannelListEntries sorting normEntries- )- , let unread = length $ filter channelListEntryUnread privEntries- coll = isHidden ChannelGroupPrivateChannels- in ( ChannelListGroup ChannelGroupPrivateChannels unread coll (length privEntries)- , if coll then mempty else sortChannelListEntries sorting privEntries- )- , let unread = length $ filter channelListEntryUnread dmEntries- coll = isHidden ChannelGroupDirectMessages- in ( ChannelListGroup ChannelGroupDirectMessages unread coll (length dmEntries)- , if coll then mempty else sortDMChannelListEntries dmEntries- )- ]--sortChannelListEntries :: ChannelListSorting -> [ChannelListEntry] -> [ChannelListEntry]-sortChannelListEntries ChannelListSortDefault =- sortBy (comparing (\c -> (channelListEntryMuted c, channelListEntrySortValue c)))-sortChannelListEntries ChannelListSortUnreadFirst =- sortBy (comparing (not . channelListEntryUnread)) .- sortChannelListEntries ChannelListSortDefault--sortDMChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry]-sortDMChannelListEntries = sortBy compareDMChannelListEntries--partitionFavorites :: [ChannelListEntry] -> ([ChannelListEntry], [ChannelListEntry])-partitionFavorites = partition channelListEntryFavorite--getChannelEntriesByType :: TeamId -> UserPreferences -> ClientChannels -> Type -> [ChannelListEntry]-getChannelEntriesByType tId prefs cs ty =- let matches (_, info) = info^.ccInfo.cdType == ty &&- info^.ccInfo.cdTeamId == Just tId- pairs = filteredChannels matches cs- entries = mkEntry <$> pairs- mkEntry (cId, ch) = ChannelListEntry { channelListEntryChannelId = cId- , channelListEntryType = CLChannel- , channelListEntryMuted = isMuted ch- , channelListEntryUnread = hasUnread' ch- , channelListEntrySortValue = ch^.ccInfo.cdDisplayName.to T.toLower- , channelListEntryFavorite = isFavorite prefs cId- }- in entries--getDMChannelEntries :: UTCTime- -> Config- -> Maybe ClientConfig- -> UserPreferences- -> Users- -> ClientChannels- -> [ChannelListEntry]-getDMChannelEntries now config cconfig prefs us cs =- let oneOnOneDmChans = getSingleDMChannelEntries now config cconfig prefs us cs- groupChans = getGroupDMChannelEntries now config prefs cs- in groupChans <> oneOnOneDmChans--compareDMChannelListEntries :: ChannelListEntry -> ChannelListEntry -> Ordering-compareDMChannelListEntries e1 e2 =- let u1 = channelListEntryUnread e1- u2 = channelListEntryUnread e2- n1 = channelListEntrySortValue e1- n2 = channelListEntrySortValue e2- in if u1 == u2- then compare n1 n2- else if u1 && not u2- then LT- else GT--useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool-useNickname' clientConfig prefs =- let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of- Just TMNicknameOrFullname -> Just True- _ -> Nothing- accountSetting = (== TMNicknameOrFullname) <$> (_userPrefTeammateNameDisplayMode prefs)- fallback = False- in fromMaybe fallback $ accountSetting <|> serverSetting--displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text-displayNameForUser u clientConfig prefs- | useNickname' clientConfig prefs =- fromMaybe (u^.uiName) (u^.uiNickName)- | otherwise =- u^.uiName--getGroupDMChannelEntries :: UTCTime- -> Config- -> UserPreferences- -> ClientChannels- -> [ChannelListEntry]-getGroupDMChannelEntries now config prefs cs =- let matches (_, info) = info^.ccInfo.cdType == Group &&- info^.ccInfo.cdTeamId == Nothing &&- groupChannelShouldAppear now config prefs info- in fmap (\(cId, ch) -> ChannelListEntry { channelListEntryChannelId = cId- , channelListEntryType = CLGroupDM- , channelListEntryMuted = isMuted ch- , channelListEntryUnread = hasUnread' ch- , channelListEntrySortValue = ch^.ccInfo.cdDisplayName- , channelListEntryFavorite = isFavorite prefs cId- }) $- filteredChannels matches cs--getSingleDMChannelEntries :: UTCTime- -> Config- -> Maybe ClientConfig- -> UserPreferences- -> Users- -> ClientChannels- -> [ChannelListEntry]-getSingleDMChannelEntries now config cconfig prefs us cs =- let mapping = allDmChannelMappings cs- mappingWithUserInfo = catMaybes $ getInfo <$> mapping- getInfo (uId, cId) = do- c <- findChannelById cId cs- u <- findUserById uId us- case u^.uiDeleted of- True -> Nothing- False ->- if dmChannelShouldAppear now config prefs c- then return (ChannelListEntry { channelListEntryChannelId = cId- , channelListEntryType = CLUserDM uId- , channelListEntryMuted = isMuted c- , channelListEntryUnread = hasUnread' c- , channelListEntrySortValue = displayNameForUser u cconfig prefs- , channelListEntryFavorite = isFavorite prefs cId- })- else Nothing- in mappingWithUserInfo---- | Return whether the specified channel has been marked as a favorite--- channel.-isFavorite :: UserPreferences -> ChannelId -> Bool-isFavorite prefs cId = favoriteChannelPreference prefs cId == Just True---- Always show a DM channel if it has unread activity or has been marked--- as a favorite.------ If it has no unread activity and if the preferences explicitly say to--- hide it, hide it.------ Otherwise, only show it if at least one of the other conditions are--- met (see 'or' below).-dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool-dmChannelShouldAppear now config prefs c =- let ndays = configDirectChannelExpirationDays config- localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now- cutoff = ServerTime localCutoff- updated = c^.ccInfo.cdUpdated- uId = fromJust $ c^.ccInfo.cdDMUserId- cId = c^.ccInfo.cdChannelId- in if isFavorite prefs cId- then True- else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)- then True- else case dmChannelShowPreference prefs uId of- Just False -> False- _ -> or [- -- The channel was updated recently enough- updated >= cutoff- ])---- Always show a group DM channel if it has unread activity or has been--- marked as a favorite.------ If it has no unread activity and if the preferences explicitly say to--- hide it, hide it.------ Otherwise, only show it if at least one of the other conditions are--- met (see 'or' below).-groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool-groupChannelShouldAppear now config prefs c =- let ndays = configDirectChannelExpirationDays config- localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now- cutoff = ServerTime localCutoff- updated = c^.ccInfo.cdUpdated- cId = c^.ccInfo.cdChannelId- in if isFavorite prefs cId- then True- else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)- then True- else case groupChannelShowPreference prefs cId of- Just False -> False- _ -> or [- -- The channel was updated recently enough- updated >= cutoff- ])--dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool-dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps)--groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool-groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps)--favoriteChannelPreference :: UserPreferences -> ChannelId -> Maybe Bool-favoriteChannelPreference ps cId = HM.lookup cId (_userPrefFavoriteChannelPrefs ps)---- * Internal Names and References---- | This 'Name' type is the type used in 'brick' to identify various--- parts of the interface.-data Name =- ChannelMessages ChannelId- | MessageInput TeamId- | ChannelList TeamId- | HelpViewport- | HelpText- | ScriptHelpText- | ThemeHelpText- | SyntaxHighlightHelpText- | KeybindingHelpText- | ChannelSelectString TeamId- | ChannelSelectEntry ChannelSelectMatch- | CompletionAlternatives TeamId- | CompletionList TeamId- | JoinChannelList TeamId- | UrlList TeamId- | MessagePreviewViewport TeamId- | ThemeListSearchInput TeamId- | UserListSearchInput TeamId- | JoinChannelListSearchInput TeamId- | UserListSearchResults TeamId- | ThemeListSearchResults TeamId- | ViewMessageArea TeamId- | ViewMessageReactionsArea TeamId- | ChannelSidebar TeamId- | ChannelSelectInput TeamId- | AttachmentList TeamId- | AttachmentFileBrowser TeamId- | MessageReactionsArea TeamId- | ReactionEmojiList TeamId- | ReactionEmojiListInput TeamId- | TabbedWindowTabBar TeamId- | MuteToggleField TeamId- | ChannelMentionsField TeamId- | DesktopNotificationsField TeamId (WithDefault NotifyOption)- | PushNotificationsField TeamId (WithDefault NotifyOption)- | ChannelTopicEditor TeamId- | ChannelTopicSaveButton TeamId- | ChannelTopicCancelButton TeamId- | ChannelTopicEditorPreview TeamId- | ChannelTopic ChannelId- | TeamList- | ClickableChannelListEntry ChannelId- | ClickableTeamListEntry TeamId- | ClickableURL Name Int LinkTarget- | ClickableURLInMessage MessageId Int LinkTarget- | ClickableUsernameInMessage MessageId Int Text- | ClickableUsername Name Int Text- | ClickableURLListEntry Int LinkTarget- | ClickableReactionInMessage PostId Text (Set UserId)- | ClickableReaction PostId Text (Set UserId)- | ClickableAttachment FileId- | ClickableChannelListGroupHeading ChannelListGroupLabel- | AttachmentPathEditor TeamId- | AttachmentPathSaveButton TeamId- | AttachmentPathCancelButton TeamId- | RenderedMessage MessageId- | ReactionEmojiListOverlayEntry (Bool, T.Text)- | SelectedChannelListEntry TeamId- | VScrollBar Brick.ClickableScrollbarElement Name- deriving (Eq, Show, Ord)---- | Types that provide a "semantically equal" operation. Two values may--- be semantically equal even if they are not equal according to Eq if,--- for example, they are equal on the basis of some fields that are more--- pertinent than others.-class (Show a, Eq a, Ord a) => SemEq a where- semeq :: a -> a -> Bool--instance SemEq Name where- semeq (ClickableURLInMessage mId1 _ t1) (ClickableURLInMessage mId2 _ t2) = mId1 == mId2 && t1 == t2- semeq (ClickableUsernameInMessage mId1 _ n) (ClickableUsernameInMessage mId2 _ n2) = mId1 == mId2 && n == n2- semeq a b = a == b--instance SemEq a => SemEq (Maybe a) where- semeq Nothing Nothing = True- semeq (Just a) (Just b) = a `semeq` b- semeq _ _ = False---- | The sum type of exceptions we expect to encounter on authentication--- failure. We encode them explicitly here so that we can print them in--- a more user-friendly manner than just 'show'.-data AuthenticationException =- ConnectError HostCannotConnect- | ResolveError HostNotResolved- | AuthIOError IOError- | LoginError LoginFailureException- | MattermostServerError MattermostError- | OtherAuthError SomeException- deriving (Show)---- | Our 'ConnectionInfo' contains exactly as much information as is--- necessary to start a connection with a Mattermost server. This is--- built up during interactive authentication and then is used to log--- in.------ If the access token field is non-empty, that value is used and the--- username and password values are ignored.-data ConnectionInfo =- ConnectionInfo { _ciHostname :: Text- , _ciPort :: Int- , _ciUrlPath :: Text- , _ciUsername :: Text- , _ciOTPToken :: Maybe Text- , _ciPassword :: Text- , _ciAccessToken :: Text- , _ciType :: ConnectionType- }---- | We want to continue referring to posts by their IDs, but we don't--- want to have to synthesize new valid IDs for messages from the client--- itself (like error messages or informative client responses). To that--- end, a PostRef can be either a PostId or a newly-generated client ID.-data PostRef- = MMId PostId- | CLId Int- deriving (Eq, Show)---- ** Channel-matching types---- | A match in channel selection mode.-data ChannelSelectMatch =- ChannelSelectMatch { nameBefore :: Text- -- ^ The content of the match before the user's- -- matching input.- , nameMatched :: Text- -- ^ The potion of the name that matched the- -- user's input.- , nameAfter :: Text- -- ^ The portion of the name that came after the- -- user's matching input.- , matchFull :: Text- -- ^ The full string for this entry so it doesn't- -- have to be reassembled from the parts above.- , matchEntry :: ChannelListEntry- -- ^ The original entry data corresponding to the- -- text match.- }- deriving (Eq, Show, Ord)--data ChannelSelectPattern = CSP MatchType Text- | CSPAny- deriving (Eq, Show)--data MatchType =- Prefix- | Suffix- | Infix- | Equal- | PrefixDMOnly- | PrefixNonDMOnly- deriving (Eq, Show)---- * Application State Values--data ProgramOutput =- ProgramOutput { program :: FilePath- , programArgs :: [String]- , programStdout :: String- , programStderr :: String- , programExitCode :: ExitCode- }--defaultUserPreferences :: UserPreferences-defaultUserPreferences =- UserPreferences { _userPrefShowJoinLeave = True- , _userPrefFlaggedPostList = mempty- , _userPrefGroupChannelPrefs = mempty- , _userPrefDirectChannelPrefs = mempty- , _userPrefFavoriteChannelPrefs = mempty- , _userPrefTeammateNameDisplayMode = Nothing- , _userPrefTeamOrder = Nothing- }--setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences-setUserPreferences = flip (F.foldr go)- where go p u- | Just fp <- preferenceToFlaggedPost p =- u { _userPrefFlaggedPostList =- _userPrefFlaggedPostList u Seq.|> fp- }- | Just gp <- preferenceToDirectChannelShowStatus p =- u { _userPrefDirectChannelPrefs =- HM.insert- (directChannelShowUserId gp)- (directChannelShowValue gp)- (_userPrefDirectChannelPrefs u)- }- | Just gp <- preferenceToGroupChannelPreference p =- u { _userPrefGroupChannelPrefs =- HM.insert- (groupChannelId gp)- (groupChannelShow gp)- (_userPrefGroupChannelPrefs u)- }- | Just fp <- preferenceToFavoriteChannelPreference p =- u { _userPrefFavoriteChannelPrefs =- HM.insert- (favoriteChannelId fp)- (favoriteChannelShow fp)- (_userPrefFavoriteChannelPrefs u)- }- | Just tIds <- preferenceToTeamOrder p =- u { _userPrefTeamOrder = Just tIds- }- | preferenceName p == PreferenceName "join_leave" =- u { _userPrefShowJoinLeave =- preferenceValue p /= PreferenceValue "false" }- | preferenceCategory p == PreferenceCategoryDisplaySettings &&- preferenceName p == PreferenceName "name_format" =- let PreferenceValue txt = preferenceValue p- in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt }- | otherwise = u---- | Log message tags.-data LogCategory =- LogGeneral- | LogAPI- | LogWebsocket- | LogError- | LogUserMark- deriving (Eq, Show)---- | A log message.-data LogMessage =- LogMessage { logMessageText :: !Text- -- ^ The text of the log message.- , logMessageContext :: !(Maybe LogContext)- -- ^ The optional context information relevant to the log- -- message.- , logMessageCategory :: !LogCategory- -- ^ The category of the log message.- , logMessageTimestamp :: !UTCTime- -- ^ The timestamp of the log message.- }- deriving (Eq, Show)---- | A logging thread command.-data LogCommand =- LogToFile FilePath- -- ^ Start logging to the specified path.- | LogAMessage !LogMessage- -- ^ Log the specified message.- | StopLogging- -- ^ Stop any active logging.- | ShutdownLogging- -- ^ Shut down.- | GetLogDestination- -- ^ Ask the logging thread about its active logging destination.- | LogSnapshot FilePath- -- ^ Ask the logging thread to dump the current buffer to the- -- specified destination.- deriving (Show)---- | A handle to the log manager thread.-data LogManager =- LogManager { logManagerCommandChannel :: STM.TChan LogCommand- , logManagerHandle :: Async ()- }--startLoggingToFile :: LogManager -> FilePath -> IO ()-startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc--stopLoggingToFile :: LogManager -> IO ()-stopLoggingToFile mgr = sendLogCommand mgr StopLogging--requestLogSnapshot :: LogManager -> FilePath -> IO ()-requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path--requestLogDestination :: LogManager -> IO ()-requestLogDestination mgr = sendLogCommand mgr GetLogDestination--sendLogMessage :: LogManager -> LogMessage -> IO ()-sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm--sendLogCommand :: LogManager -> LogCommand -> IO ()-sendLogCommand mgr c =- STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c---- | 'ChatResources' represents configuration and connection-related--- information, as opposed to current model or view information.--- Information that goes in the 'ChatResources' value should be limited--- to information that we read or set up prior to setting up the bulk of--- the application state.-data ChatResources =- ChatResources { _crSession :: Session- , _crWebsocketThreadId :: Maybe ThreadId- , _crConn :: ConnectionData- , _crRequestQueue :: RequestChan- , _crEventQueue :: BCH.BChan MHEvent- , _crSubprocessLog :: STM.TChan ProgramOutput- , _crWebsocketActionChan :: STM.TChan WebsocketAction- , _crTheme :: AttrMap- , _crStatusUpdateChan :: STM.TChan [UserId]- , _crConfiguration :: Config- , _crFlaggedPosts :: Set PostId- , _crUserPreferences :: UserPreferences- , _crSyntaxMap :: SyntaxMap- , _crLogManager :: LogManager- , _crEmoji :: EmojiCollection- }---- | A "special" mention that does not map to a specific user, but is an--- alias that the server uses to notify users.-data SpecialMention =- MentionAll- -- ^ @all: notify everyone in the channel.- | MentionChannel- -- ^ @channel: notify everyone in the channel.--data AutocompleteAlternative =- UserCompletion User Bool- -- ^ User, plus whether the user is in the channel that triggered- -- the autocomplete- | SpecialMention SpecialMention- -- ^ A special mention.- | ChannelCompletion Bool Channel- -- ^ Channel, plus whether the user is a member of the channel- | SyntaxCompletion Text- -- ^ Name of a skylighting syntax definition- | CommandCompletion CompletionSource Text Text Text- -- ^ Source, name of a slash command, argspec, and description- | EmojiCompletion Text- -- ^ The text of an emoji completion---- | The source of an autocompletion alternative.-data CompletionSource = Server | Client- deriving (Eq, Show)--specialMentionName :: SpecialMention -> Text-specialMentionName MentionChannel = "channel"-specialMentionName MentionAll = "all"--isSpecialMention :: T.Text -> Bool-isSpecialMention n = isJust $ lookup (T.toLower $ trimUserSigil n) pairs- where- pairs = mkPair <$> mentions- mentions = [ MentionChannel- , MentionAll- ]- mkPair v = (specialMentionName v, v)--autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text-autocompleteAlternativeReplacement (EmojiCompletion e) =- ":" <> e <> ":"-autocompleteAlternativeReplacement (SpecialMention m) =- addUserSigil $ specialMentionName m-autocompleteAlternativeReplacement (UserCompletion u _) =- addUserSigil $ userUsername u-autocompleteAlternativeReplacement (ChannelCompletion _ c) =- normalChannelSigil <> (sanitizeUserText $ channelName c)-autocompleteAlternativeReplacement (SyntaxCompletion t) =- "```" <> t-autocompleteAlternativeReplacement (CommandCompletion _ t _ _) =- "/" <> t---- | The type of data that the autocompletion logic supports. We use--- this to track the kind of completion underway in case the type of--- completion needs to change.-data AutocompletionType =- ACUsers- | ACChannels- | ACCodeBlockLanguage- | ACEmoji- | ACCommands- deriving (Eq, Show)--data AutocompleteState =- AutocompleteState { _acPreviousSearchString :: Text- -- ^ The search string used for the- -- currently-displayed autocomplete results, for- -- use in deciding whether to issue another server- -- query- , _acCompletionList :: List Name AutocompleteAlternative- -- ^ The list of alternatives that the user- -- selects from- , _acType :: AutocompletionType- -- ^ The type of data that we're completing- , _acCachedResponses :: HM.HashMap Text [AutocompleteAlternative]- -- ^ A cache of alternative lists, keyed on search- -- string, for use in avoiding server requests.- -- The idea here is that users type quickly enough- -- (and edit their input) that would normally lead- -- to rapid consecutive requests, some for the- -- same strings during editing, that we can avoid- -- that by caching them here. Note that this cache- -- gets destroyed whenever autocompletion is not- -- on, so this cache does not live very long.- }---- | The 'ChatEditState' value contains the editor widget itself as well--- as history and metadata we need for editing-related operations.-data ChatEditState =- ChatEditState { _cedEditor :: Editor Text Name- , _cedEditMode :: EditMode- , _cedEphemeral :: EphemeralEditState- , _cedYankBuffer :: Text- , _cedSpellChecker :: Maybe (Aspell, IO ())- , _cedMisspellings :: Set Text- , _cedAutocomplete :: Maybe AutocompleteState- -- ^ The autocomplete state. The autocompletion UI is- -- showing only when this state is present.- , _cedAutocompletePending :: Maybe Text- -- ^ The search string associated with the latest- -- in-flight autocompletion request. This is used to- -- determine whether any (potentially late-arriving)- -- API responses are for stale queries since the user- -- can type more quickly than the server can get us- -- the results, and we wouldn't want to show results- -- associated with old editor states.- , _cedAttachmentList :: List Name AttachmentData- -- ^ The list of attachments to be uploaded with the- -- post being edited.- , _cedFileBrowser :: Maybe (FB.FileBrowser Name)- -- ^ The browser for selecting attachment files.- -- This is a Maybe because the instantiation of the- -- FileBrowser causes it to read and ingest the- -- target directory, so this action is deferred- -- until the browser is needed.- , _cedJustCompleted :: Bool- -- A flag that indicates whether the most recent- -- editing event was a tab-completion. This is used by- -- the smart trailing space handling.- }---- | An attachment.-data AttachmentData =- AttachmentData { attachmentDataFileInfo :: FB.FileInfo- , attachmentDataBytes :: BS.ByteString- }- deriving (Eq, Show)---- | We can initialize a new 'ChatEditState' value with just an edit--- history, which we save locally.-emptyEditState :: TeamId -> ChatEditState-emptyEditState tId =- ChatEditState { _cedEditor = editor (MessageInput tId) Nothing ""- , _cedEphemeral = defaultEphemeralEditState- , _cedEditMode = NewPost- , _cedYankBuffer = ""- , _cedSpellChecker = Nothing- , _cedMisspellings = mempty- , _cedAutocomplete = Nothing- , _cedAutocompletePending = Nothing- , _cedAttachmentList = list (AttachmentList tId) mempty 1- , _cedFileBrowser = Nothing- , _cedJustCompleted = False- }---- | A 'RequestChan' is a queue of operations we have to perform in the--- background to avoid blocking on the main loop-type RequestChan = STM.TChan (IO (Maybe (MH ())))---- | The 'HelpScreen' type represents the set of possible 'Help'--- dialogues we have to choose from.-data HelpScreen =- MainHelp- | ScriptHelp- | ThemeHelp- | SyntaxHighlightHelp- | KeybindingHelp- deriving (Eq, Show)---- | Help topics-data HelpTopic =- HelpTopic { helpTopicName :: Text- , helpTopicDescription :: Text- , helpTopicScreen :: HelpScreen- , helpTopicViewportName :: Name- }- deriving (Eq, Show)---- | Mode type for the current contents of the post list overlay-data PostListContents =- PostListFlagged- | PostListPinned ChannelId- | PostListSearch Text Bool -- for the query and search status- deriving (Eq, Show)---- | The 'Mode' represents the current dominant UI activity-data Mode =- Main- | ShowHelp HelpTopic Mode- | ChannelSelect- | UrlSelect- | LeaveChannelConfirm- | DeleteChannelConfirm- | MessageSelect- | MessageSelectDeleteConfirm- | PostListOverlay PostListContents- | UserListOverlay- | ReactionEmojiListOverlay- | ChannelListOverlay- | ThemeListOverlay- | ViewMessage- | ManageAttachments- | ManageAttachmentsBrowseFiles- | EditNotifyPrefs- | ChannelTopicWindow- | SaveAttachmentWindow LinkChoice- deriving (Eq, Show)---- | We're either connected or we're not.-data ConnectionStatus = Connected | Disconnected deriving (Eq)---- | An entry in a tabbed window corresponding to a tab and its content.--- Parameterized over an abstract handle type ('a') for the tabs so we--- can give each a unique handle.-data TabbedWindowEntry a =- TabbedWindowEntry { tweValue :: a- -- ^ The handle for this tab.- , tweRender :: a -> ChatState -> Widget Name- -- ^ The rendering function to use when this tab- -- is selected.- , tweHandleEvent :: a -> Vty.Event -> MH ()- -- ^ The event-handling function to use when this- -- tab is selected.- , tweTitle :: a -> Bool -> T.Text- -- ^ Title function for this tab, with a boolean- -- indicating whether this is the current tab.- , tweShowHandler :: a -> MH ()- -- ^ A handler to be invoked when this tab is- -- shown.- }---- | The definition of a tabbed window. Note that this does not track--- the *state* of the window; it merely provides a collection of tab--- window entries (see above). To track the state of a tabbed window,--- use a TabbedWindow.------ Parameterized over an abstract handle type ('a') for the tabs so we--- can give each a unique handle.-data TabbedWindowTemplate a =- TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a]- -- ^ The entries in tabbed windows with this- -- structure.- , twtTitle :: a -> Widget Name- -- ^ The title-rendering function for this kind- -- of tabbed window.- }---- | An instantiated tab window. This is based on a template and tracks--- the state of the tabbed window (current tab).------ Parameterized over an abstract handle type ('a') for the tabs so we--- can give each a unique handle.-data TabbedWindow a =- TabbedWindow { twValue :: a- -- ^ The handle of the currently-selected tab.- , twReturnMode :: Mode- -- ^ The mode to return to when the tab is closed.- , twTemplate :: TabbedWindowTemplate a- -- ^ The template to use as a basis for rendering the- -- window and handling user input.- , twWindowWidth :: Int- , twWindowHeight :: Int- -- ^ Window dimensions- }---- | Construct a new tabbed window from a template. This will raise an--- exception if the initially-selected tab does not exist in the window--- template, or if the window template has any duplicated tab handles.------ Note that the caller is responsible for determining whether to call--- the initially-selected tab's on-show handler.-tabbedWindow :: (Show a, Eq a)- => a- -- ^ The handle corresponding to the tab that should be- -- selected initially.- -> TabbedWindowTemplate a- -- ^ The template for the window to construct.- -> Mode- -- ^ When the window is closed, return to this application- -- mode.- -> (Int, Int)- -- ^ The window dimensions (width, height).- -> TabbedWindow a-tabbedWindow initialVal t retMode (width, height) =- let handles = tweValue <$> twtEntries t- in if | null handles ->- error "BUG: tabbed window template must provide at least one entry"- | length handles /= length (nub handles) ->- error "BUG: tabbed window should have one entry per handle"- | not (initialVal `elem` handles) ->- error $ "BUG: tabbed window handle " <>- show initialVal <> " not present in template"- | otherwise ->- TabbedWindow { twTemplate = t- , twValue = initialVal- , twReturnMode = retMode- , twWindowWidth = width- , twWindowHeight = height- }---- | Get the currently-selected tab entry for a tabbed window. Raise--- an exception if the window's selected tab handle is not found in its--- template (which is a bug in the tabbed window infrastructure).-getCurrentTabbedWindowEntry :: (Show a, Eq a)- => TabbedWindow a- -> TabbedWindowEntry a-getCurrentTabbedWindowEntry w =- lookupTabbedWindowEntry (twValue w) w---- | Run the on-show handler for the window tab entry with the specified--- handle.-runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH ()-runTabShowHandlerFor handle w = do- let entry = lookupTabbedWindowEntry handle w- tweShowHandler entry handle---- | Look up a tabbed window entry by handle. Raises an exception if no--- such entry exists.-lookupTabbedWindowEntry :: (Eq a, Show a)- => a- -> TabbedWindow a- -> TabbedWindowEntry a-lookupTabbedWindowEntry handle w =- let matchesVal e = tweValue e == handle- in case filter matchesVal (twtEntries $ twTemplate w) of- [e] -> e- _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <>- " should have matched a single entry"---- | Switch a tabbed window's selected tab to its next tab, cycling back--- to the first tab if the last tab is the selected tab. This also--- invokes the on-show handler for the newly-selected tab.------ Note that this does nothing if the window has only one tab.-tabbedWindowNextTab :: (Show a, Eq a)- => TabbedWindow a- -> MH (TabbedWindow a)-tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w-tabbedWindowNextTab w = do- let curIdx = case elemIndex (tweValue curEntry) allHandles of- Nothing ->- error $ "BUG: tabbedWindowNextTab: could not find " <>- "current handle in handle list"- Just i -> i- nextIdx = if curIdx == length allHandles - 1- then 0- else curIdx + 1- newHandle = allHandles !! nextIdx- allHandles = tweValue <$> twtEntries (twTemplate w)- curEntry = getCurrentTabbedWindowEntry w- newWin = w { twValue = newHandle }-- runTabShowHandlerFor newHandle newWin- return newWin---- | Switch a tabbed window's selected tab to its previous tab, cycling--- to the last tab if the first tab is the selected tab. This also--- invokes the on-show handler for the newly-selected tab.------ Note that this does nothing if the window has only one tab.-tabbedWindowPreviousTab :: (Show a, Eq a)- => TabbedWindow a- -> MH (TabbedWindow a)-tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w-tabbedWindowPreviousTab w = do- let curIdx = case elemIndex (tweValue curEntry) allHandles of- Nothing ->- error $ "BUG: tabbedWindowPreviousTab: could not find " <>- "current handle in handle list"- Just i -> i- nextIdx = if curIdx == 0- then length allHandles - 1- else curIdx - 1- newHandle = allHandles !! nextIdx- allHandles = tweValue <$> twtEntries (twTemplate w)- curEntry = getCurrentTabbedWindowEntry w- newWin = w { twValue = newHandle }-- runTabShowHandlerFor newHandle newWin- return newWin--data ChannelListOrientation =- ChannelListLeft- -- ^ Show the channel list to the left of the message area.- | ChannelListRight- -- ^ Show the channel list to the right of the message area.- deriving (Eq, Show)---- | This type represents the current state of our application at any--- given time.-data ChatState =- ChatState { _csResources :: ChatResources- -- ^ Global application-wide resources that don't change- -- much.- , _csLastMouseDownEvent :: Maybe (Brick.BrickEvent Name MHEvent)- -- ^ The most recent mouse click event we got. We reset- -- this on mouse up so we can ignore clicks whenever this- -- is already set.- , _csVerbatimTruncateSetting :: Maybe Int- -- ^ The current verbatim block truncation setting. This- -- is used to toggle truncation behavior and is updated- -- from the configTruncateVerbatimBlocks Config field.- , _csTeams :: HashMap TeamId TeamState- -- ^ The state for each team that we are in.- , _csTeamZipper :: Z.Zipper () TeamId- -- ^ The list of teams we can cycle through.- , _csChannelListOrientation :: ChannelListOrientation- -- ^ The orientation of the channel list.- , _csMe :: User- -- ^ The authenticated user.- , _csChannels :: ClientChannels- -- ^ The channels that we are showing, including their- -- message lists.- , _csHiddenChannelGroups :: HM.HashMap TeamId (Set ChannelListGroupLabel)- -- ^ The set of channel list groups that are currently- -- collapsed in the sidebar.- , _csPostMap :: HashMap PostId Message- -- ^ The map of post IDs to messages. This allows us to- -- access messages by ID without having to linearly scan- -- channel message lists.- , _csUsers :: Users- -- ^ All of the users we know about.- , _timeZone :: TimeZoneSeries- -- ^ The client time zone.- , _csConnectionStatus :: ConnectionStatus- -- ^ Our view of the connection status.- , _csWorkerIsBusy :: Maybe (Maybe Int)- -- ^ Whether the async worker thread is busy, and its- -- queue length if so.- , _csClientConfig :: Maybe ClientConfig- -- ^ The Mattermost client configuration, as we understand it.- , _csInputHistory :: InputHistory- -- ^ The map of per-channel input history for the- -- application. We don't distribute the per-channel- -- history into the per-channel states (like we do- -- for other per-channel state) since keeping it- -- under the InputHistory banner lets us use a nicer- -- startup/shutdown disk file management API.- }---- | All application state specific to a team, along with state specific--- to our user interface's presentation of that team. We include the--- UI state relevant to the team so that we can easily switch which--- team the UI is presenting without having to reinitialize the UI from--- the new team. This allows the user to be engaged in just about any--- application activity while viewing a team, switch to another team,--- and return to the original team and resume what they were doing, all--- without us doing any work.-data TeamState =- TeamState { _tsFocus :: Z.Zipper ChannelListGroup ChannelListEntry- -- ^ The channel sidebar zipper that tracks which channel- -- is selected.- , _tsPendingChannelChange :: Maybe PendingChannelChange- -- ^ A pending channel change that we need to apply once- -- the channel in question is available. We set this up- -- when we need to change to a channel in the sidebar, but- -- it isn't even there yet because we haven't loaded its- -- metadata.- , _tsRecentChannel :: Maybe ChannelId- -- ^ The most recently-selected channel, if any.- , _tsReturnChannel :: Maybe ChannelId- -- ^ The channel to return to after visiting one or more- -- unread channels.- , _tsEditState :: ChatEditState- -- ^ The state of the input box used for composing and- -- editing messages and commands.- , _tsMessageSelect :: MessageSelectState- -- ^ The state of message selection mode.- , _tsTeam :: Team- -- ^ The team data.- , _tsChannelSelectState :: ChannelSelectState- -- ^ The state of the user's input and selection for- -- channel selection mode.- , _tsUrlList :: List Name (Int, LinkChoice)- -- ^ The URL list used to show URLs drawn from messages in- -- a channel.- , _tsViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab)- -- ^ Set when the ViewMessage mode is active. The message- -- being viewed. Note that this stores a message, not- -- a message ID. That's because not all messages have- -- message IDs (e.g. client messages) and we still- -- want to support viewing of those messages. It's the- -- responsibility of code that uses this message to always- -- consult the chat state for the latest *version* of any- -- message with an ID here, to be sure that the latest- -- version is used (e.g. if it gets edited, etc.).- , _tsPostListOverlay :: PostListOverlayState- -- ^ The state of the post list overlay.- , _tsUserListOverlay :: ListOverlayState UserInfo UserSearchScope- -- ^ The state of the user list overlay.- , _tsChannelListOverlay :: ListOverlayState Channel ChannelSearchScope- -- ^ The state of the user list overlay.- , _tsNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name)- -- ^ A form for editing the notification preferences for- -- the current channel. This is set when entering- -- EditNotifyPrefs mode and updated when the user- -- changes the form state.- , _tsChannelTopicDialog :: ChannelTopicDialogState- -- ^ The state for the interactive channel topic editor- -- window.- , _tsMode :: Mode- -- ^ The current application mode when viewing this team.- -- This is used to dispatch to different rendering and- -- event handling routines.- , _tsReactionEmojiListOverlay :: ListOverlayState (Bool, T.Text) ()- -- ^ The state of the reaction emoji list overlay.- , _tsThemeListOverlay :: ListOverlayState InternalTheme ()- -- ^ The state of the theme list overlay.- , _tsSaveAttachmentDialog :: SaveAttachmentDialogState- -- ^ The state for the interactive attachment-saving- -- editor window.- , _tsChannelListSorting :: ChannelListSorting- -- ^ How to sort channels in this team's channel list- -- groups- }---- | Handles for the View Message window's tabs.-data ViewMessageWindowTab =- VMTabMessage- -- ^ The message tab.- | VMTabReactions- -- ^ The reactions tab.- deriving (Eq, Show)--data PendingChannelChange =- ChangeByChannelId TeamId ChannelId (Maybe (MH ()))- | ChangeByUserId UserId---- | Startup state information that is constructed prior to building a--- ChatState.-data StartupStateInfo =- StartupStateInfo { startupStateResources :: ChatResources- , startupStateConnectedUser :: User- , startupStateTeams :: HM.HashMap TeamId TeamState- , startupStateTimeZone :: TimeZoneSeries- , startupStateInitialHistory :: InputHistory- , startupStateInitialTeam :: TeamId- }---- | The state of the channel topic editor window.-data ChannelTopicDialogState =- ChannelTopicDialogState { _channelTopicDialogEditor :: Editor T.Text Name- -- ^ The topic string editor state.- , _channelTopicDialogFocus :: FocusRing Name- -- ^ The window focus state (editor/buttons)- }---- | The state of the attachment path window.-data SaveAttachmentDialogState =- SaveAttachmentDialogState { _attachmentPathEditor :: Editor T.Text Name- -- ^ The attachment path editor state.- , _attachmentPathDialogFocus :: FocusRing Name- -- ^ The window focus state (editor/buttons)- }--sortTeams :: [Team] -> [Team]-sortTeams = sortBy (compare `on` (T.strip . sanitizeUserText . teamName))--matchesTeam :: T.Text -> Team -> Bool-matchesTeam tName t =- let normalizeUserText = normalize . sanitizeUserText- normalize = T.strip . T.toLower- urlName = normalizeUserText $ teamName t- displayName = normalizeUserText $ teamDisplayName t- in normalize tName `elem` [displayName, urlName]--mkTeamZipper :: HM.HashMap TeamId TeamState -> Z.Zipper () TeamId-mkTeamZipper m =- let sortedTeams = sortTeams $ _tsTeam <$> HM.elems m- in mkTeamZipperFromIds $ teamId <$> sortedTeams--mkTeamZipperFromIds :: [TeamId] -> Z.Zipper () TeamId-mkTeamZipperFromIds tIds = Z.fromList [((), tIds)]--teamZipperIds :: Z.Zipper () TeamId -> [TeamId]-teamZipperIds = concat . fmap snd . Z.toList--newTeamState :: Config- -> Team- -> Z.Zipper ChannelListGroup ChannelListEntry- -> Maybe (Aspell, IO ())- -> TeamState-newTeamState config team chanList spellChecker =- let tId = teamId team- in TeamState { _tsMode = Main- , _tsFocus = chanList- , _tsEditState = (emptyEditState tId) { _cedSpellChecker = spellChecker }- , _tsTeam = team- , _tsUrlList = list (UrlList tId) mempty 2- , _tsPostListOverlay = PostListOverlayState emptyDirSeq Nothing- , _tsUserListOverlay = nullUserListOverlayState tId- , _tsChannelListOverlay = nullChannelListOverlayState tId- , _tsChannelSelectState = emptyChannelSelectState tId- , _tsChannelTopicDialog = newChannelTopicDialog tId ""- , _tsMessageSelect = MessageSelectState Nothing- , _tsNotifyPrefs = Nothing- , _tsPendingChannelChange = Nothing- , _tsRecentChannel = Nothing- , _tsReturnChannel = Nothing- , _tsViewedMessage = Nothing- , _tsThemeListOverlay = nullThemeListOverlayState tId- , _tsReactionEmojiListOverlay = nullEmojiListOverlayState tId- , _tsSaveAttachmentDialog = newSaveAttachmentDialog tId ""- , _tsChannelListSorting = configChannelListSorting config- }---- | Make a new channel topic editor window state.-newChannelTopicDialog :: TeamId -> T.Text -> ChannelTopicDialogState-newChannelTopicDialog tId t =- ChannelTopicDialogState { _channelTopicDialogEditor = editor (ChannelTopicEditor tId) Nothing t- , _channelTopicDialogFocus = focusRing [ ChannelTopicEditor tId- , ChannelTopicSaveButton tId- , ChannelTopicCancelButton tId- ]- }---- | Make a new attachment-saving editor window state.-newSaveAttachmentDialog :: TeamId -> T.Text -> SaveAttachmentDialogState-newSaveAttachmentDialog tId t =- SaveAttachmentDialogState { _attachmentPathEditor = applyEdit Z2.gotoEOL $- editor (AttachmentPathEditor tId) (Just 1) t- , _attachmentPathDialogFocus = focusRing [ AttachmentPathEditor tId- , AttachmentPathSaveButton tId- , AttachmentPathCancelButton tId- ]- }--nullChannelListOverlayState :: TeamId -> ListOverlayState Channel ChannelSearchScope-nullChannelListOverlayState tId =- let newList rs = list (JoinChannelList tId) rs 2- in ListOverlayState { _listOverlaySearchResults = newList mempty- , _listOverlaySearchInput = editor (JoinChannelListSearchInput tId) (Just 1) ""- , _listOverlaySearchScope = AllChannels- , _listOverlaySearching = False- , _listOverlayEnterHandler = const $ return False- , _listOverlayNewList = newList- , _listOverlayFetchResults = const $ const $ const $ return mempty- , _listOverlayRecordCount = Nothing- , _listOverlayReturnMode = Main- }--nullThemeListOverlayState :: TeamId -> ListOverlayState InternalTheme ()-nullThemeListOverlayState tId =- let newList rs = list (ThemeListSearchResults tId) rs 3- in ListOverlayState { _listOverlaySearchResults = newList mempty- , _listOverlaySearchInput = editor (ThemeListSearchInput tId) (Just 1) ""- , _listOverlaySearchScope = ()- , _listOverlaySearching = False- , _listOverlayEnterHandler = const $ return False- , _listOverlayNewList = newList- , _listOverlayFetchResults = const $ const $ const $ return mempty- , _listOverlayRecordCount = Nothing- , _listOverlayReturnMode = Main- }--nullUserListOverlayState :: TeamId -> ListOverlayState UserInfo UserSearchScope-nullUserListOverlayState tId =- let newList rs = list (UserListSearchResults tId) rs 1- in ListOverlayState { _listOverlaySearchResults = newList mempty- , _listOverlaySearchInput = editor (UserListSearchInput tId) (Just 1) ""- , _listOverlaySearchScope = AllUsers Nothing- , _listOverlaySearching = False- , _listOverlayEnterHandler = const $ return False- , _listOverlayNewList = newList- , _listOverlayFetchResults = const $ const $ const $ return mempty- , _listOverlayRecordCount = Nothing- , _listOverlayReturnMode = Main- }--nullEmojiListOverlayState :: TeamId -> ListOverlayState (Bool, T.Text) ()-nullEmojiListOverlayState tId =- let newList rs = list (ReactionEmojiList tId) rs 1- in ListOverlayState { _listOverlaySearchResults = newList mempty- , _listOverlaySearchInput = editor (ReactionEmojiListInput tId) (Just 1) ""- , _listOverlaySearchScope = ()- , _listOverlaySearching = False- , _listOverlayEnterHandler = const $ return False- , _listOverlayNewList = newList- , _listOverlayFetchResults = const $ const $ const $ return mempty- , _listOverlayRecordCount = Nothing- , _listOverlayReturnMode = MessageSelect- }---- | The state of channel selection mode.-data ChannelSelectState =- ChannelSelectState { _channelSelectInput :: Editor Text Name- , _channelSelectMatches :: Z.Zipper ChannelListGroup ChannelSelectMatch- }--emptyChannelSelectState :: TeamId -> ChannelSelectState-emptyChannelSelectState tId =- ChannelSelectState { _channelSelectInput = editor (ChannelSelectInput tId) (Just 1) ""- , _channelSelectMatches = Z.fromList []- }---- | The state of message selection mode.-data MessageSelectState =- MessageSelectState { selectMessageId :: Maybe MessageId- }---- | The state of the post list overlay.-data PostListOverlayState =- PostListOverlayState { _postListPosts :: Messages- , _postListSelected :: Maybe PostId- }--data InternalTheme =- InternalTheme { internalThemeName :: Text- , internalTheme :: Theme- , internalThemeDesc :: Text- }---- | The state of the search result list overlay. Type 'a' is the type--- of data in the list. Type 'b' is the search scope type.-data ListOverlayState a b =- ListOverlayState { _listOverlaySearchResults :: List Name a- -- ^ The list of search results currently shown in- -- the overlay.- , _listOverlaySearchInput :: Editor Text Name- -- ^ The editor for the overlay's search input.- , _listOverlaySearchScope :: b- -- ^ The overlay's current search scope.- , _listOverlaySearching :: Bool- -- ^ Whether a search is in progress (i.e. whether- -- we are currently awaiting a response from a- -- search query to the server).- , _listOverlayEnterHandler :: a -> MH Bool- -- ^ The handler to invoke on the selected element- -- when the user presses Enter.- , _listOverlayNewList :: Vec.Vector a -> List Name a- -- ^ The function to build a new brick List from a- -- vector of search results.- , _listOverlayFetchResults :: b -> Session -> Text -> IO (Vec.Vector a)- -- ^ The function to call to issue a search query- -- to the server.- , _listOverlayRecordCount :: Maybe Int- -- ^ The total number of available records, if known.- , _listOverlayReturnMode :: Mode- -- ^ The mode to return to when the window closes.- }---- | The scope for searching for users in a user list overlay.-data UserSearchScope =- ChannelMembers ChannelId TeamId- | ChannelNonMembers ChannelId TeamId- | AllUsers (Maybe TeamId)---- | The scope for searching for channels to join.-data ChannelSearchScope =- AllChannels---- | Actions that can be sent on the websocket to the server.-data WebsocketAction =- UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box- deriving (Read, Show, Eq, Ord)---- * MH Monad---- | Logging context information, in the event that metadata should--- accompany a log message.-data LogContext =- LogContext { logContextChannelId :: Maybe ChannelId- }- deriving (Eq, Show)---- | A user fetching strategy.-data UserFetch =- UserFetchById UserId- -- ^ Fetch the user with the specified ID.- | UserFetchByUsername Text- -- ^ Fetch the user with the specified username.- | UserFetchByNickname Text- -- ^ Fetch the user with the specified nickname.- deriving (Eq, Show)--data MHState =- MHState { mhCurrentState :: ChatState- , mhNextAction :: ChatState -> EventM Name (Next ChatState)- , mhUsersToFetch :: [UserFetch]- , mhPendingStatusList :: Maybe [UserId]- }---- | A value of type 'MH' @a@ represents a computation that can--- manipulate the application state and also request that the--- application quit-newtype MH a =- MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name)) a }---- | Use a modified logging context for the duration of the specified MH--- action.-withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a-withLogContext modifyContext act =- MH $ R.withReaderT modifyContext (fromMH act)--withLogContextChannelId :: ChannelId -> MH a -> MH a-withLogContextChannelId cId act =- let f Nothing = Just $ LogContext (Just cId)- f (Just c) = Just $ c { logContextChannelId = Just cId }- in withLogContext f act---- | Get the current logging context.-getLogContext :: MH (Maybe LogContext)-getLogContext = MH R.ask---- | Log a message.-mhLog :: LogCategory -> Text -> MH ()-mhLog cat msg = do- logger <- mhGetIOLogger- liftIO $ logger cat msg---- | Get a logger suitable for use in IO. The logger always logs using--- the MH monad log context at the time of the call to mhGetIOLogger.-mhGetIOLogger :: MH (LogCategory -> Text -> IO ())-mhGetIOLogger = do- ctx <- getLogContext- mgr <- use (to (_crLogManager . _csResources))- return $ ioLogWithManager mgr ctx--ioLogWithManager :: LogManager -> Maybe LogContext -> LogCategory -> Text -> IO ()-ioLogWithManager mgr ctx cat msg = do- now <- getCurrentTime- let lm = LogMessage { logMessageText = msg- , logMessageContext = ctx- , logMessageCategory = cat- , logMessageTimestamp = now- }- sendLogMessage mgr lm---- | Run an 'MM' computation, choosing whether to continue or halt based--- on the resulting-runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState)-runMHEvent st (MH mote) = do- let mhSt = MHState { mhCurrentState = st- , mhNextAction = Brick.continue- , mhUsersToFetch = []- , mhPendingStatusList = Nothing- }- ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt- (mhNextAction st') (mhCurrentState st')--scheduleUserFetches :: [UserFetch] -> MH ()-scheduleUserFetches fs = MH $ do- St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s }--scheduleUserStatusFetches :: [UserId] -> MH ()-scheduleUserStatusFetches is = MH $ do- St.modify $ \s -> s { mhPendingStatusList = Just is }--getScheduledUserFetches :: MH [UserFetch]-getScheduledUserFetches = MH $ St.gets mhUsersToFetch--getScheduledUserStatusFetches :: MH (Maybe [UserId])-getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList---- | lift a computation in 'EventM' into 'MH'-mh :: EventM Name a -> MH a-mh = MH . R.lift . St.lift--generateUUID :: MH UUID-generateUUID = liftIO generateUUID_IO--generateUUID_IO :: IO UUID-generateUUID_IO = randomIO--mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH ()-mhHandleEventLensed ln f event = MH $ do- s <- St.get- let st = mhCurrentState s- n <- R.lift $ St.lift $ f event (st ^. ln)- St.put (s { mhCurrentState = st & ln .~ n })--mhHandleEventLensed' :: Lens' ChatState b -> (b -> EventM Name b) -> MH ()-mhHandleEventLensed' ln f = MH $ do- s <- St.get- let st = mhCurrentState s- n <- R.lift $ St.lift $ f (st ^. ln)- St.put (s { mhCurrentState = st & ln .~ n })--mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()-mhSuspendAndResume mote = MH $ do- s <- St.get- St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) }--mhContinueWithoutRedraw :: MH ()-mhContinueWithoutRedraw = MH $ do- s <- St.get- St.put $ s { mhNextAction = \ _ -> Brick.continueWithoutRedraw (mhCurrentState s) }---- | This will request that after this computation finishes the--- application should exit-requestQuit :: MH ()-requestQuit = MH $ do- s <- St.get- St.put $ s { mhNextAction = Brick.halt }--instance Functor MH where- fmap f (MH x) = MH (fmap f x)--instance Applicative MH where- pure x = MH (pure x)- MH f <*> MH x = MH (f <*> x)--instance MHF.MonadFail MH where- fail = MH . MHF.fail--instance Monad MH where- return = pure- MH x >>= f = MH (x >>= \ x' -> fromMH (f x'))---- We want to pretend that the state is only the ChatState, rather--- than the ChatState and the Brick continuation-instance St.MonadState ChatState MH where- get = mhCurrentState `fmap` MH St.get- put st = MH $ do- s <- St.get- St.put $ s { mhCurrentState = st }--instance St.MonadIO MH where- liftIO = MH . St.liftIO---- | This represents events that we handle in the main application loop.-data MHEvent =- WSEvent WebsocketEvent- -- ^ For events that arise from the websocket- | WSActionResponse WebsocketActionResponse- -- ^ For responses to websocket actions- | RespEvent (MH ())- -- ^ For the result values of async IO operations- | RefreshWebsocketEvent- -- ^ Tell our main loop to refresh the websocket connection- | WebsocketParseError String- -- ^ We failed to parse an incoming websocket event- | WebsocketDisconnect- -- ^ The websocket connection went down.- | WebsocketConnect- -- ^ The websocket connection came up.- | BGIdle- -- ^ background worker is idle- | BGBusy (Maybe Int)- -- ^ background worker is busy (with n requests)- | RateLimitExceeded Int- -- ^ A request initially failed due to a rate limit but will be- -- retried if possible. The argument is the number of seconds in- -- which the retry will be attempted.- | RateLimitSettingsMissing- -- ^ A request denied by a rate limit could not be retried because- -- the response contained no rate limit metadata- | RequestDropped- -- ^ A request was reattempted due to a rate limit and was rate- -- limited again- | IEvent InternalEvent- -- ^ MH-internal events---- | Internal application events.-data InternalEvent =- DisplayError MHError- -- ^ Some kind of application error occurred- | LoggingStarted FilePath- | LoggingStopped FilePath- | LogStartFailed FilePath String- | LogDestination (Maybe FilePath)- | LogSnapshotSucceeded FilePath- | LogSnapshotFailed FilePath String- -- ^ Logging events from the logging thread---- | Application errors.-data MHError =- GenericError T.Text- -- ^ A generic error message constructor- | NoSuchChannel T.Text- -- ^ The specified channel does not exist- | NoSuchUser T.Text- -- ^ The specified user does not exist- | AmbiguousName T.Text- -- ^ The specified name matches both a user and a channel- | ServerError MattermostError- -- ^ A Mattermost server error occurred- | ClipboardError T.Text- -- ^ A problem occurred trying to deal with yanking or the system- -- clipboard- | ConfigOptionMissing T.Text- -- ^ A missing config option is required to perform an operation- | ProgramExecutionFailed T.Text T.Text- -- ^ Args: program name, path to log file. A problem occurred when- -- running the program.- | NoSuchScript T.Text- -- ^ The specified script was not found- | NoSuchHelpTopic T.Text- -- ^ The specified help topic was not found- | AttachmentException SomeException- -- ^ IO operations for attaching a file threw an exception- | BadAttachmentPath T.Text- -- ^ The specified file is either a directory or doesn't exist- | AsyncErrEvent SomeException- -- ^ For errors that arise in the course of async IO operations- deriving (Show)---- ** Application State Lenses--makeLenses ''ChatResources-makeLenses ''ChatState-makeLenses ''TeamState-makeLenses ''ChatEditState-makeLenses ''AutocompleteState-makeLenses ''PostListOverlayState-makeLenses ''ListOverlayState-makeLenses ''ChannelSelectState-makeLenses ''UserPreferences-makeLenses ''ConnectionInfo-makeLenses ''ChannelTopicDialogState-makeLenses ''SaveAttachmentDialogState-Brick.suffixLenses ''Config--applyTeamOrderPref :: Maybe [TeamId] -> ChatState -> ChatState-applyTeamOrderPref Nothing st = st-applyTeamOrderPref (Just prefTIds) st =- let teams = _csTeams st- ourTids = HM.keys teams- tIds = filter (`elem` ourTids) prefTIds- curTId = st^.csCurrentTeamId- unmentioned = filter (not . wasMentioned) $ HM.elems teams- wasMentioned ts = (teamId $ _tsTeam ts) `elem` tIds- zipperTids = tIds <> (teamId <$> sortTeams (_tsTeam <$> unmentioned))- in st { _csTeamZipper = (Z.findRight ((== curTId) . Just) $ mkTeamZipperFromIds zipperTids)- }--refreshTeamZipper :: MH ()-refreshTeamZipper = do- tidOrder <- use (csResources.crUserPreferences.userPrefTeamOrder)- St.modify (applyTeamOrderPref tidOrder)--applyTeamOrder :: [TeamId] -> MH ()-applyTeamOrder tIds = St.modify (applyTeamOrderPref $ Just tIds)--newState :: StartupStateInfo -> ChatState-newState (StartupStateInfo {..}) =- let config = _crConfiguration startupStateResources- in applyTeamOrderPref (_userPrefTeamOrder $ _crUserPreferences startupStateResources) $- ChatState { _csResources = startupStateResources- , _csLastMouseDownEvent = Nothing- , _csVerbatimTruncateSetting = configTruncateVerbatimBlocks config- , _csTeamZipper = Z.findRight (== startupStateInitialTeam) $- mkTeamZipper startupStateTeams- , _csTeams = startupStateTeams- , _csChannelListOrientation = configChannelListOrientation config- , _csMe = startupStateConnectedUser- , _csChannels = noChannels- , _csPostMap = HM.empty- , _csUsers = noUsers- , _timeZone = startupStateTimeZone- , _csConnectionStatus = Connected- , _csWorkerIsBusy = Nothing- , _csClientConfig = Nothing- , _csInputHistory = startupStateInitialHistory- , _csHiddenChannelGroups = mempty- }--getServerBaseUrl :: TeamId -> MH TeamBaseURL-getServerBaseUrl tId = do- st <- use id- return $ serverBaseUrl st tId--serverBaseUrl :: ChatState -> TeamId -> TeamBaseURL-serverBaseUrl st tId =- let baseUrl = connectionDataURL $ _crConn $ _csResources st- tName = teamName $ st^.csTeam(tId).tsTeam- in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl--unsafeCedFileBrowser :: Lens' ChatEditState (FB.FileBrowser Name)-unsafeCedFileBrowser =- lens (\st -> st^.cedFileBrowser ^?! _Just)- (\st t -> st & cedFileBrowser .~ Just t)--getSession :: MH Session-getSession = use (csResources.crSession)--getResourceSession :: ChatResources -> Session-getResourceSession = _crSession--whenMode :: TeamId -> Mode -> MH () -> MH ()-whenMode tId m act = do- curMode <- use (csTeam(tId).tsMode)- when (curMode == m) act--setMode :: TeamId -> Mode -> MH ()-setMode tId m = do- csTeam(tId).tsMode .= m- mh invalidateCache--setMode' :: TeamId -> Mode -> ChatState -> ChatState-setMode' tId m = csTeam(tId).tsMode .~ m--resetSpellCheckTimer :: ChatEditState -> IO ()-resetSpellCheckTimer s =- case s^.cedSpellChecker of- Nothing -> return ()- Just (_, reset) -> reset---- ** Utility Lenses-csCurrentChannelId :: TeamId -> SimpleGetter ChatState (Maybe ChannelId)-csCurrentChannelId tId =- csTeam(tId).tsFocus.to Z.focus.to (fmap channelListEntryChannelId)--withCurrentTeam :: (TeamId -> MH ()) -> MH ()-withCurrentTeam f = do- mtId <- use csCurrentTeamId- case mtId of- Nothing -> return ()- Just tId -> f tId--withCurrentChannel :: TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()-withCurrentChannel tId f = do- mcId <- use $ csCurrentChannelId tId- case mcId of- Nothing -> return ()- Just cId -> do- mChan <- preuse $ csChannel cId- case mChan of- Just ch -> f cId ch- _ -> return ()--withCurrentChannel' :: TeamId -> (ChannelId -> ClientChannel -> MH (Maybe a)) -> MH (Maybe a)-withCurrentChannel' tId f = do- mcId <- use $ csCurrentChannelId tId- case mcId of- Nothing -> return Nothing- Just cId -> do- mChan <- preuse $ csChannel cId- case mChan of- Just ch -> f cId ch- _ -> return Nothing--csCurrentTeamId :: SimpleGetter ChatState (Maybe TeamId)-csCurrentTeamId = csTeamZipper.to Z.focus--csTeam :: TeamId -> Lens' ChatState TeamState-csTeam tId =- lens (\ st -> st ^. csTeams . at tId ^?! _Just)- (\ st t -> st & csTeams . at tId .~ Just t)--channelListEntryUserId :: ChannelListEntry -> Maybe UserId-channelListEntryUserId e =- case channelListEntryType e of- CLUserDM uId -> Just uId- _ -> Nothing--userIdsFromZipper :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId]-userIdsFromZipper z =- concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.toList z--entryIsDMEntry :: ChannelListEntry -> Bool-entryIsDMEntry e =- case channelListEntryType e of- CLUserDM {} -> True- CLGroupDM {} -> True- CLChannel {} -> False--csChannel :: ChannelId -> Traversal' ChatState ClientChannel-csChannel cId =- csChannels . channelByIdL cId--withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH ()-withChannel cId = withChannelOrDefault cId ()--withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a-withChannelOrDefault cId deflt mote = do- chan <- preuse (csChannel(cId))- case chan of- Nothing -> return deflt- Just c -> mote c---- ** 'ChatState' Helper Functions--raiseInternalEvent :: InternalEvent -> MH ()-raiseInternalEvent ev = do- queue <- use (csResources.crEventQueue)- writeBChan queue (IEvent ev)--writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m ()-writeBChan chan e = do- written <- liftIO $ BCH.writeBChanNonBlocking chan e- when (not written) $- error $ "mhSendEvent: BChan full, please report this as a bug!"---- | Log and raise an error.-mhError :: MHError -> MH ()-mhError err = do- mhLog LogError $ T.pack $ show err- raiseInternalEvent (DisplayError err)--isMine :: ChatState -> Message -> Bool-isMine st msg =- case msg^.mUser of- UserI _ uid -> uid == myUserId st- _ -> False--getMessageForPostId :: ChatState -> PostId -> Maybe Message-getMessageForPostId st pId = st^.csPostMap.at(pId)--getParentMessage :: ChatState -> Message -> Maybe Message-getParentMessage st msg- | InReplyTo pId <- msg^.mInReplyToMsg- = st^.csPostMap.at(pId)- | otherwise = Nothing--getReplyRootMessage :: Message -> MH Message-getReplyRootMessage msg = do- case postRootId =<< (msg^.mOriginalPost) of- Nothing -> return msg- Just rootId -> do- st <- use id- case getMessageForPostId st rootId of- -- NOTE: this case should never happen. This is the- -- case where a message has a root post ID but we- -- don't have a copy of the root post in storage. This- -- shouldn't happen because whenever we add a message- -- to a channel, we always fetch the parent post and- -- store it if it is in a thread. That should mean that- -- whenever we reply to a post, if that post is itself- -- a reply, we should have its root post in storage- -- and this case should never match. Even though it- -- shouldn't happen, rather than raising a BUG exception- -- here we'll just fall back to the input message.- Nothing -> return msg- Just m -> return m--setUserStatus :: UserId -> Text -> MH ()-setUserStatus uId t = do- csUsers %= modifyUserById uId (uiStatus .~ statusFromText t)- cs <- use csChannels- forM_ (allTeamIds cs) $ \tId ->- mh $ invalidateCacheEntry $ ChannelSidebar tId--usernameForUserId :: UserId -> ChatState -> Maybe Text-usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers)--displayNameForUserId :: UserId -> ChatState -> Maybe Text-displayNameForUserId uId st = do- u <- findUserById uId (st^.csUsers)- return $ displayNameForUser u (st^.csClientConfig) (st^.csResources.crUserPreferences)---- | Note: this only searches users we have already loaded. Be--- aware that if you think you need a user we haven't fetched, use--- withFetchedUser!-userIdForUsername :: Text -> ChatState -> Maybe UserId-userIdForUsername name st =- fst <$> (findUserByUsername name $ st^.csUsers)--channelIdByChannelName :: TeamId -> Text -> ChatState -> Maybe ChannelId-channelIdByChannelName tId name st =- let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name) &&- cc^.ccInfo.cdTeamId == (Just tId)- in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels)--channelIdByUsername :: Text -> ChatState -> Maybe ChannelId-channelIdByUsername name st = do- uId <- userIdForUsername name st- getDmChannelFor uId (st^.csChannels)--useNickname :: ChatState -> Bool-useNickname st =- useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences)--trimChannelSigil :: Text -> Text-trimChannelSigil n- | normalChannelSigil `T.isPrefixOf` n = T.tail n- | otherwise = n--addNewUser :: UserInfo -> MH ()-addNewUser u = do- csUsers %= addUser u- -- Invalidate the cache because channel message rendering may need- -- to get updated if this user authored posts in any channels.- mh invalidateCache--data SidebarUpdate =- SidebarUpdateImmediate- | SidebarUpdateDeferred- deriving (Eq, Show)---resetAutocomplete :: TeamId -> MH ()-resetAutocomplete tId = do- csTeam(tId).tsEditState.cedAutocomplete .= Nothing- csTeam(tId).tsEditState.cedAutocompletePending .= Nothing----- * Slash Commands---- | The 'CmdArgs' type represents the arguments to a slash-command; the--- type parameter represents the argument structure.-data CmdArgs :: K.Type -> K.Type where- NoArg :: CmdArgs ()- LineArg :: Text -> CmdArgs Text- UserArg :: CmdArgs rest -> CmdArgs (Text, rest)- ChannelArg :: CmdArgs rest -> CmdArgs (Text, rest)- TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest)---- | A 'CmdExec' value represents the implementation of a command when--- provided with its arguments-type CmdExec a = a -> MH ()---- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec'--- implementation with a name and a description.-data Cmd =- forall a. Cmd { cmdName :: Text- , cmdDescr :: Text- , cmdArgSpec :: CmdArgs a- , cmdAction :: CmdExec a- }---- | Helper function to extract the name out of a 'Cmd' value-commandName :: Cmd -> Text-commandName (Cmd name _ _ _ ) = name---- * Channel Updates and Notifications--userList :: ChatState -> [UserInfo]-userList st = filter showUser $ allUsers (st^.csUsers)- where showUser u = not (isSelf u) && (u^.uiInTeam)- isSelf u = (myUserId st) == (u^.uiId)--allUserIds :: ChatState -> [UserId]-allUserIds st = getAllUserIds $ st^.csUsers---- BEWARE: you probably don't want this, but instead--- State.Users.withFetchedUser, since this only looks up users in the--- collection we have already loaded rather than all valid users on the--- server.-userById :: UserId -> ChatState -> Maybe UserInfo-userById uId st = findUserById uId (st^.csUsers)--myUserId :: ChatState -> UserId-myUserId st = myUser st ^. userIdL--myUser :: ChatState -> User-myUser st = st^.csMe--myUsername :: ChatState -> Text-myUsername st = userUsername $ st^.csMe---- BEWARE: you probably don't want this, but instead--- State.Users.withFetchedUser, since this only looks up users in the--- collection we have already loaded rather than all valid users on the--- server.-userByUsername :: Text -> ChatState -> Maybe UserInfo-userByUsername name st = do- snd <$> (findUserByUsername name $ st^.csUsers)---- BEWARE: you probably don't want this, but instead--- State.Users.withFetchedUser, since this only looks up users in the--- collection we have already loaded rather than all valid users on the--- server.-userByNickname :: Text -> ChatState -> Maybe UserInfo-userByNickname name st =- snd <$> (findUserByNickname name $ st^.csUsers)--getUsers :: MH Users-getUsers = use csUsers---- * HighlightSet--type UserSet = Set Text-type ChannelSet = Set Text---- | The set of usernames, channel names, and language names used for--- highlighting when rendering messages.-data HighlightSet =- HighlightSet { hUserSet :: Set Text- , hChannelSet :: Set Text- , hSyntaxMap :: SyntaxMap- }--emptyHSet :: HighlightSet-emptyHSet = HighlightSet Set.empty Set.empty mempty--getHighlightSet :: ChatState -> TeamId -> HighlightSet-getHighlightSet st tId =- HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers- , hChannelSet = getChannelNameSet tId $ st^.csChannels- , hSyntaxMap = st^.csResources.crSyntaxMap- }--attrNameToConfig :: Brick.AttrName -> Text-attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents---- From: https://docs.mattermost.com/help/messaging/mentioning-teammates.html-specialUserMentions :: [T.Text]-specialUserMentions = ["all", "channel", "here"]--addSpecialUserMentions :: Set Text -> Set Text-addSpecialUserMentions s = foldr Set.insert s specialUserMentions--getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator-getNewMessageCutoff cId st = do- cc <- st^?csChannel(cId)- return $ cc^.ccInfo.cdNewMessageIndicator--getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime-getEditedMessageCutoff cId st = do- cc <- st^?csChannel(cId)- cc^.ccInfo.cdEditedMessageThreshold--clearChannelUnreadStatus :: ChannelId -> MH ()-clearChannelUnreadStatus cId = do- mh $ invalidateCacheEntry (ChannelMessages cId)- csChannel(cId) %= (clearNewMessageIndicator .- clearEditedThreshold)--moveLeft :: (Eq a) => a -> [a] -> [a]-moveLeft v as =- case elemIndex v as of- Nothing -> as- Just 0 -> as- Just i ->- let (h, t) = splitAt i as- in init h <> [v, last h] <> tail t--moveRight :: (Eq a) => a -> [a] -> [a]-moveRight v as =- case elemIndex v as of- Nothing -> as- Just i- | i == length as - 1 -> as- | otherwise ->- let (h, t) = splitAt i as- in h <> [head (tail t), v] <> (tail (tail t))--resultToWidget :: Result n -> Widget n-resultToWidget = Widget Fixed Fixed . return+module Matterhorn.Types+ ( ConnectionStatus(..)+ , HelpTopic(..)+ , ProgramOutput(..)+ , MHEvent(..)+ , InternalEvent(..)+ , StartupStateInfo(..)+ , MHError(..)+ , CPUUsagePolicy(..)+ , SemEq(..)+ , handleEventWith+ , getServerBaseUrl+ , serverBaseUrl+ , ConnectionInfo(..)+ , SidebarUpdate(..)+ , PendingChannelChange(..)+ , ViewMessageWindowTab(..)+ , clearChannelUnreadStatus+ , ChannelListSorting(..)+ , ThreadOrientation(..)+ , ChannelListOrientation(..)+ , channelListEntryUserId+ , userIdsFromZipper+ , entryIsDMEntry+ , ciHostname+ , ciPort+ , ciUrlPath+ , ciUsername+ , ciOTPToken+ , ciPassword+ , ciType+ , ciAccessToken+ , ChannelTopicDialogState(..)+ , channelTopicDialogEditor+ , channelTopicDialogFocus++ , resultToWidget++ , Config(..)+ , configUserL+ , configHostL+ , configTeamL+ , configPortL+ , configUrlPathL+ , configPassL+ , configTokenL+ , configTimeFormatL+ , configDateFormatL+ , configThemeL+ , configThemeCustomizationFileL+ , configSmartBacktickL+ , configSmartEditingL+ , configURLOpenCommandL+ , configURLOpenCommandInteractiveL+ , configActivityNotifyCommandL+ , configActivityNotifyVersionL+ , configActivityBellL+ , configTruncateVerbatimBlocksL+ , configChannelListSortingL+ , configShowMessageTimestampsL+ , configShowBackgroundL+ , configShowMessagePreviewL+ , configShowChannelListL+ , configShowExpandedChannelTopicsL+ , configEnableAspellL+ , configAspellDictionaryL+ , configUnsafeUseHTTPL+ , configValidateServerCertificateL+ , configChannelListWidthL+ , configLogMaxBufferSizeL+ , configShowOlderEditsL+ , configShowTypingIndicatorL+ , configSendTypingNotificationsL+ , configAbsPathL+ , configUserKeysL+ , configHyperlinkingModeL+ , configSyntaxDirsL+ , configDirectChannelExpirationDaysL+ , configCpuUsagePolicyL+ , configDefaultAttachmentPathL+ , configChannelListOrientationL+ , configThreadOrientationL+ , configMouseModeL+ , configShowLastOpenThreadL++ , NotificationVersion(..)+ , PasswordSource(..)+ , TokenSource(..)+ , MatchType(..)+ , Mode(..)+ , ChannelSelectPattern(..)+ , PostListContents(..)+ , AuthenticationException(..)+ , BackgroundInfo(..)+ , RequestChan+ , UserFetch(..)+ , writeBChan+ , InternalTheme(..)++ , attrNameToConfig++ , sortTeams+ , matchesTeam+ , mkTeamZipper+ , mkTeamZipperFromIds+ , teamZipperIds+ , mkChannelZipperList+ , ChannelListGroup(..)+ , nonDMChannelListGroupUnread++ , ThreadInterface+ , ChannelMessageInterface++ , threadInterface+ , unsafeThreadInterface+ , maybeThreadInterface+ , threadInterfaceEmpty+ , threadInterfaceDeleteWhere+ , modifyThreadMessages+ , modifyEachThreadMessage++ , trimChannelSigil++ , ChannelSelectState(..)+ , channelSelectMatches+ , channelSelectInput+ , emptyChannelSelectState++ , TeamState(..)+ , tsFocus+ , tsPendingChannelChange+ , tsRecentChannel+ , tsReturnChannel+ , tsTeam+ , tsChannelSelectState+ , tsViewedMessage+ , tsPostListWindow+ , tsUserListWindow+ , tsChannelListWindow+ , tsNotifyPrefs+ , tsChannelTopicDialog+ , tsReactionEmojiListWindow+ , tsThemeListWindow+ , tsChannelListSorting+ , tsThreadInterface+ , tsMessageInterfaceFocus++ , teamMode+ , teamModes+ , getTeamMode++ , MessageInterfaceFocus(..)+ , messageInterfaceFocusNext+ , messageInterfaceFocusPrev++ , channelEditor+ , channelMessageSelect++ , ChatState+ , newState++ , withCurrentChannel+ , withCurrentChannel'+ , withCurrentTeam++ , csTeamZipper+ , csTeams+ , csTeam+ , csChannelListOrientation+ , csResources+ , csLastMouseDownEvent+ , csGlobalEditState+ , csVerbatimTruncateSetting+ , csCurrentChannelId+ , csCurrentTeamId+ , csPostMap+ , csUsers+ , csHiddenChannelGroups+ , csConnectionStatus+ , csWorkerIsBusy+ , csChannel+ , csChannelMessages+ , csChannelMessageInterface+ , maybeChannelMessageInterface+ , csChannels+ , csClientConfig+ , csInputHistory+ , csMe+ , timeZone+ , whenMode+ , pushMode+ , pushMode'+ , popMode+ , replaceMode++ , GlobalEditState(..)+ , emptyGlobalEditState+ , gedYankBuffer++ , PostListWindowState(..)+ , postListSelected+ , postListPosts++ , UserSearchScope(..)+ , ChannelSearchScope(..)++ , ListWindowState(..)+ , listWindowSearchResults+ , listWindowSearchInput+ , listWindowSearchScope+ , listWindowSearching+ , listWindowEnterHandler+ , listWindowNewList+ , listWindowFetchResults+ , listWindowRecordCount++ , getUsers++ , ChatResources(..)+ , crUserPreferences+ , crEventQueue+ , crTheme+ , crStatusUpdateChan+ , crSubprocessLog+ , crWebsocketActionChan+ , crWebsocketThreadId+ , crRequestQueue+ , crFlaggedPosts+ , crConn+ , crConfiguration+ , crSyntaxMap+ , crLogManager+ , crSpellChecker+ , crEmoji+ , getSession+ , getResourceSession++ , specialUserMentions++ , applyTeamOrder+ , refreshTeamZipper++ , UserPreferences(UserPreferences)+ , userPrefShowJoinLeave+ , userPrefFlaggedPostList+ , userPrefGroupChannelPrefs+ , userPrefDirectChannelPrefs+ , userPrefTeammateNameDisplayMode+ , userPrefTeamOrder+ , userPrefFavoriteChannelPrefs+ , dmChannelShowPreference+ , groupChannelShowPreference+ , favoriteChannelPreference++ , defaultUserPreferences+ , setUserPreferences++ , WebsocketAction(..)++ , Cmd(..)+ , commandName+ , CmdArgs(..)++ , MH+ , runMHEvent+ , scheduleUserFetches+ , scheduleUserStatusFetches+ , getScheduledUserFetches+ , getScheduledUserStatusFetches+ , mh+ , generateUUID+ , generateUUID_IO+ , mhSuspendAndResume+ , mhHandleEventLensed+ , mhHandleEventLensed'+ , mhContinueWithoutRedraw+ , St.gets+ , mhError++ , mhLog+ , mhGetIOLogger+ , ioLogWithManager+ , LogContext(..)+ , withLogContext+ , withLogContextChannelId+ , getLogContext+ , LogMessage(..)+ , LogCommand(..)+ , LogCategory(..)++ , LogManager(..)+ , startLoggingToFile+ , stopLoggingToFile+ , requestLogSnapshot+ , requestLogDestination+ , sendLogMessage++ , requestQuit+ , getMessageForPostId+ , getParentMessage+ , getReplyRootMessage+ , withChannel+ , withChannelOrDefault+ , userList+ , resetAutocomplete+ , isMine+ , setUserStatus+ , myUser+ , myUsername+ , myUserId+ , usernameForUserId+ , userByUsername+ , userByNickname+ , channelIdByChannelName+ , channelIdByUsername+ , userById+ , allUserIds+ , addNewUser+ , useNickname+ , useNickname'+ , displayNameForUserId+ , displayNameForUser+ , raiseInternalEvent+ , getNewMessageCutoff+ , getEditedMessageCutoff++ , HighlightSet(..)+ , UserSet+ , ChannelSet+ , getHighlightSet+ , emptyHSet++ , moveLeft+ , moveRight++ , module Matterhorn.Types.Core+ , module Matterhorn.Types.Channels+ , module Matterhorn.Types.EditState+ , module Matterhorn.Types.Messages+ , module Matterhorn.Types.MessageInterface+ , module Matterhorn.Types.TabbedWindow+ , module Matterhorn.Types.Posts+ , module Matterhorn.Types.Users+ )+where++import Prelude ()+import Matterhorn.Prelude++import GHC.Stack ( HasCallStack )++import qualified Brick+import Brick ( EventM, Next, Widget(..), Size(..), Result )+import Brick.Focus ( FocusRing )+import Brick.Themes ( Theme )+import Brick.Main ( invalidateCache, invalidateCacheEntry )+import Brick.AttrMap ( AttrMap )+import qualified Brick.BChan as BCH+import Brick.Forms (Form)+import Brick.Widgets.Edit ( Editor, editor )+import Brick.Widgets.List ( List )+import Control.Concurrent ( ThreadId )+import Control.Concurrent.Async ( Async )+import qualified Control.Concurrent.STM as STM+import Control.Exception ( SomeException )+import qualified Control.Monad.Fail as MHF+import qualified Control.Monad.State as St+import qualified Control.Monad.Reader as R+import qualified Data.Set as Set+import qualified Data.Foldable as F+import Data.Function ( on )+import qualified Data.Kind as K+import Data.Maybe ( fromJust )+import Data.Ord ( comparing )+import qualified Data.HashMap.Strict as HM+import Data.List ( sortBy, elemIndex, partition )+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import Data.Time.Clock ( getCurrentTime, addUTCTime )+import Data.UUID ( UUID )+import qualified Data.Vector as Vec+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( at, makeLenses, lens, (^?!), (.=)+ , (%=), (%~), (.~), _Just, Traversal', to+ , SimpleGetter, filtered, traversed, singular+ )+import Network.Connection ( HostNotResolved, HostCannotConnect )+import Skylighting.Types ( SyntaxMap )+import System.Exit ( ExitCode )+import System.Random ( randomIO )+import Text.Aspell ( Aspell )++import Network.Mattermost ( ConnectionData )+import Network.Mattermost.Exceptions+import Network.Mattermost.Lenses+import Network.Mattermost.Types+import Network.Mattermost.Types.Config+import Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse )++import Matterhorn.Constants ( normalChannelSigil )+import Matterhorn.InputHistory+import Matterhorn.Emoji+import Matterhorn.Types.Common+import Matterhorn.Types.Core+import Matterhorn.Types.Channels+import Matterhorn.Types.EditState+import Matterhorn.Types.KeyEvents+import Matterhorn.Types.Messages+import Matterhorn.Types.MessageInterface+import Matterhorn.Types.NonemptyStack+import Matterhorn.Types.Posts+import Matterhorn.Types.RichText ( TeamBaseURL(..), TeamURLName(..) )+import Matterhorn.Types.TabbedWindow+import Matterhorn.Types.Users+import qualified Matterhorn.Zipper as Z+++-- * Configuration++-- | A notification version for the external notifier+data NotificationVersion =+ NotifyV1+ | NotifyV2+ deriving (Eq, Read, Show)++-- | A user password is either given to us directly, or a command+-- which we execute to find the password.+data PasswordSource =+ PasswordString Text+ | PasswordCommand Text+ deriving (Eq, Read, Show)++-- | An access token source.+data TokenSource =+ TokenString Text+ | TokenCommand Text+ deriving (Eq, Read, Show)++-- | The type of channel list group headings. Integer arguments indicate+-- total number of channels in the group that have unread activity.+data ChannelListGroup =+ ChannelListGroup { channelListGroupLabel :: ChannelListGroupLabel+ , channelListGroupUnread :: Int+ , channelListGroupCollapsed :: Bool+ , channelListGroupEntries :: Int+ }+ deriving (Eq, Show)++nonDMChannelListGroupUnread :: ChannelListGroup -> Int+nonDMChannelListGroupUnread g =+ case channelListGroupLabel g of+ ChannelGroupDirectMessages -> 0+ _ -> channelListGroupUnread g++data ChannelListSorting =+ ChannelListSortDefault+ | ChannelListSortUnreadFirst+ deriving (Eq, Show, Ord)++-- | This is how we represent the user's configuration. Most fields+-- correspond to configuration file settings (see Config.hs) but some+-- are for internal book-keeping purposes only.+data Config =+ Config { configUser :: Maybe Text+ -- ^ The username to use when connecting.+ , configHost :: Maybe Text+ -- ^ The hostname to use when connecting.+ , configTeam :: Maybe Text+ -- ^ The team name to use when connecting.+ , configPort :: Int+ -- ^ The port to use when connecting.+ , configUrlPath :: Maybe Text+ -- ^ The server path to use when connecting.+ , configPass :: Maybe PasswordSource+ -- ^ The password source to use when connecting.+ , configToken :: Maybe TokenSource+ -- ^ The token source to use when connecting.+ , configTimeFormat :: Maybe Text+ -- ^ The format string for timestamps.+ , configDateFormat :: Maybe Text+ -- ^ The format string for dates.+ , configTheme :: Maybe Text+ -- ^ The name of the theme to use.+ , configThemeCustomizationFile :: Maybe Text+ -- ^ The path to the theme customization file, if any.+ , configSmartBacktick :: Bool+ -- ^ Whether to enable smart quoting characters.+ , configSmartEditing :: Bool+ -- ^ Whether to enable smart editing behaviors.+ , configURLOpenCommand :: Maybe Text+ -- ^ The command to use to open URLs.+ , configURLOpenCommandInteractive :: Bool+ -- ^ Whether the URL-opening command is interactive (i.e.+ -- whether it should be given control of the terminal).+ , configActivityNotifyCommand :: Maybe T.Text+ -- ^ The command to run for activity notifications.+ , configActivityNotifyVersion :: NotificationVersion+ -- ^ The activity notifier version.+ , configActivityBell :: Bool+ -- ^ Whether to ring the terminal bell on activity.+ , configTruncateVerbatimBlocks :: Maybe Int+ -- ^ Whether to truncate verbatim (and code) blocks past a+ -- reasonable number of lines.+ , configShowMessageTimestamps :: Bool+ -- ^ Whether to show timestamps on messages.+ , configShowBackground :: BackgroundInfo+ -- ^ Whether to show async background worker thread info.+ , configShowMessagePreview :: Bool+ -- ^ Whether to show the message preview area.+ , configShowChannelList :: Bool+ -- ^ Whether to show the channel list.+ , configShowExpandedChannelTopics :: Bool+ -- ^ Whether to show expanded channel topics.+ , configEnableAspell :: Bool+ -- ^ Whether to enable Aspell spell checking.+ , configAspellDictionary :: Maybe Text+ -- ^ A specific Aspell dictionary name to use.+ , configUnsafeUseHTTP :: Bool+ -- ^ Whether to permit an insecure HTTP connection.+ , configValidateServerCertificate :: Bool+ -- ^ Whether to validate TLS certificates.+ , configChannelListWidth :: Int+ -- ^ The width, in columns, of the channel list sidebar.+ , configLogMaxBufferSize :: Int+ -- ^ The maximum size, in log entries, of the internal log+ -- message buffer.+ , configShowOlderEdits :: Bool+ -- ^ Whether to highlight the edit indicator on edits made+ -- prior to the beginning of the current session.+ , configChannelListSorting :: ChannelListSorting+ -- ^ How to sort channels in each channel list group+ , configShowTypingIndicator :: Bool+ -- ^ Whether to show the typing indicator when other users+ -- are typing+ , configSendTypingNotifications :: Bool+ -- Whether to send typing notifications to other users.+ , configAbsPath :: Maybe FilePath+ -- ^ A book-keeping field for the absolute path to the+ -- configuration. (Not a user setting.)+ , configUserKeys :: KeyConfig+ -- ^ The user's keybinding configuration.+ , configHyperlinkingMode :: Bool+ -- ^ Whether to enable terminal hyperlinking mode.+ , configSyntaxDirs :: [FilePath]+ -- ^ The search path for syntax description XML files.+ , configDirectChannelExpirationDays :: Int+ -- ^ The number of days to show a user in the channel menu after a direct+ -- message with them.+ , configCpuUsagePolicy :: CPUUsagePolicy+ -- ^ The CPU usage policy for the application.+ , configDefaultAttachmentPath :: Maybe FilePath+ -- ^ The default path for browsing attachments+ , configChannelListOrientation :: ChannelListOrientation+ -- ^ The orientation of the channel list.+ , configThreadOrientation :: ThreadOrientation+ -- ^ The orientation of the thread window relative to the+ -- main channel message window.+ , configMouseMode :: Bool+ -- ^ Whether to enable mouse support in matterhorn+ , configShowLastOpenThread :: Bool+ -- ^ Whether to re-open a thread that was open the last time+ -- Matterhorn quit+ } deriving (Eq, Show)++-- | The policy for CPU usage.+--+-- The idea is that Matterhorn can benefit from using multiple CPUs,+-- but the exact number is application-determined. We expose this policy+-- setting to the user in the configuration.+data CPUUsagePolicy =+ SingleCPU+ -- ^ Constrain the application to use one CPU.+ | MultipleCPUs+ -- ^ Permit the usage of multiple CPUs (the exact number is+ -- determined by the application).+ deriving (Eq, Show)++-- | The state of the UI diagnostic indicator for the async worker+-- thread.+data BackgroundInfo =+ Disabled+ -- ^ Disable (do not show) the indicator.+ | Active+ -- ^ Show the indicator when the thread is working.+ | ActiveCount+ -- ^ Show the indicator when the thread is working, but include the+ -- thread's work queue length.+ deriving (Eq, Show)++data UserPreferences =+ UserPreferences { _userPrefShowJoinLeave :: Bool+ , _userPrefFlaggedPostList :: Seq FlaggedPost+ , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool+ , _userPrefDirectChannelPrefs :: HashMap UserId Bool+ , _userPrefFavoriteChannelPrefs :: HashMap ChannelId Bool+ , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode+ , _userPrefTeamOrder :: Maybe [TeamId]+ }++hasUnread' :: ClientChannel -> Bool+hasUnread' chan = fromMaybe False $ do+ let info = _ccInfo chan+ lastViewTime <- _cdViewed info+ return $ _cdMentionCount info > 0 ||+ (not (isMuted chan) &&+ (((_cdUpdated info) > lastViewTime) ||+ (isJust $ _cdEditedMessageThreshold info)))++mkChannelZipperList :: ChannelListSorting+ -> UTCTime+ -> Config+ -> TeamId+ -> Maybe ClientConfig+ -> UserPreferences+ -> HM.HashMap TeamId (Set ChannelListGroupLabel)+ -> ClientChannels+ -> Users+ -> [(ChannelListGroup, [ChannelListEntry])]+mkChannelZipperList sorting now config tId cconfig prefs hidden cs us =+ let (privFavs, privEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Private+ (normFavs, normEntries) = partitionFavorites $ getChannelEntriesByType tId prefs cs Ordinary+ (dmFavs, dmEntries) = partitionFavorites $ getDMChannelEntries now config cconfig prefs us cs+ favEntries = privFavs <> normFavs <> dmFavs+ isHidden label =+ case HM.lookup tId hidden of+ Nothing -> False+ Just s -> Set.member label s+ in [ let unread = length $ filter channelListEntryUnread favEntries+ coll = isHidden ChannelGroupFavoriteChannels+ in ( ChannelListGroup ChannelGroupFavoriteChannels unread coll (length favEntries)+ , if coll then mempty else sortChannelListEntries sorting favEntries+ )+ , let unread = length $ filter channelListEntryUnread normEntries+ coll = isHidden ChannelGroupPublicChannels+ in ( ChannelListGroup ChannelGroupPublicChannels unread coll (length normEntries)+ , if coll then mempty else sortChannelListEntries sorting normEntries+ )+ , let unread = length $ filter channelListEntryUnread privEntries+ coll = isHidden ChannelGroupPrivateChannels+ in ( ChannelListGroup ChannelGroupPrivateChannels unread coll (length privEntries)+ , if coll then mempty else sortChannelListEntries sorting privEntries+ )+ , let unread = length $ filter channelListEntryUnread dmEntries+ coll = isHidden ChannelGroupDirectMessages+ in ( ChannelListGroup ChannelGroupDirectMessages unread coll (length dmEntries)+ , if coll then mempty else sortDMChannelListEntries dmEntries+ )+ ]++sortChannelListEntries :: ChannelListSorting -> [ChannelListEntry] -> [ChannelListEntry]+sortChannelListEntries ChannelListSortDefault =+ sortBy (comparing (\c -> (channelListEntryMuted c, channelListEntrySortValue c)))+sortChannelListEntries ChannelListSortUnreadFirst =+ sortBy (comparing (not . channelListEntryUnread)) .+ sortChannelListEntries ChannelListSortDefault++sortDMChannelListEntries :: [ChannelListEntry] -> [ChannelListEntry]+sortDMChannelListEntries = sortBy compareDMChannelListEntries++partitionFavorites :: [ChannelListEntry] -> ([ChannelListEntry], [ChannelListEntry])+partitionFavorites = partition channelListEntryFavorite++getChannelEntriesByType :: TeamId -> UserPreferences -> ClientChannels -> Type -> [ChannelListEntry]+getChannelEntriesByType tId prefs cs ty =+ let matches (_, info) = info^.ccInfo.cdType == ty &&+ info^.ccInfo.cdTeamId == Just tId+ pairs = filteredChannels matches cs+ entries = mkEntry <$> pairs+ mkEntry (cId, ch) = ChannelListEntry { channelListEntryChannelId = cId+ , channelListEntryType = CLChannel+ , channelListEntryMuted = isMuted ch+ , channelListEntryUnread = hasUnread' ch+ , channelListEntrySortValue = ch^.ccInfo.cdDisplayName.to T.toLower+ , channelListEntryFavorite = isFavorite prefs cId+ }+ in entries++getDMChannelEntries :: UTCTime+ -> Config+ -> Maybe ClientConfig+ -> UserPreferences+ -> Users+ -> ClientChannels+ -> [ChannelListEntry]+getDMChannelEntries now config cconfig prefs us cs =+ let oneOnOneDmChans = getSingleDMChannelEntries now config cconfig prefs us cs+ groupChans = getGroupDMChannelEntries now config prefs cs+ in groupChans <> oneOnOneDmChans++compareDMChannelListEntries :: ChannelListEntry -> ChannelListEntry -> Ordering+compareDMChannelListEntries e1 e2 =+ let u1 = channelListEntryUnread e1+ u2 = channelListEntryUnread e2+ n1 = channelListEntrySortValue e1+ n2 = channelListEntrySortValue e2+ in if u1 == u2+ then compare n1 n2+ else if u1 && not u2+ then LT+ else GT++useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool+useNickname' clientConfig prefs =+ let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of+ Just TMNicknameOrFullname -> Just True+ _ -> Nothing+ accountSetting = (== TMNicknameOrFullname) <$> (_userPrefTeammateNameDisplayMode prefs)+ fallback = False+ in fromMaybe fallback $ accountSetting <|> serverSetting++displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text+displayNameForUser u clientConfig prefs+ | useNickname' clientConfig prefs =+ fromMaybe (u^.uiName) (u^.uiNickName)+ | otherwise =+ u^.uiName++getGroupDMChannelEntries :: UTCTime+ -> Config+ -> UserPreferences+ -> ClientChannels+ -> [ChannelListEntry]+getGroupDMChannelEntries now config prefs cs =+ let matches (_, info) = info^.ccInfo.cdType == Group &&+ info^.ccInfo.cdTeamId == Nothing &&+ groupChannelShouldAppear now config prefs info+ in fmap (\(cId, ch) -> ChannelListEntry { channelListEntryChannelId = cId+ , channelListEntryType = CLGroupDM+ , channelListEntryMuted = isMuted ch+ , channelListEntryUnread = hasUnread' ch+ , channelListEntrySortValue = ch^.ccInfo.cdDisplayName+ , channelListEntryFavorite = isFavorite prefs cId+ }) $+ filteredChannels matches cs++getSingleDMChannelEntries :: UTCTime+ -> Config+ -> Maybe ClientConfig+ -> UserPreferences+ -> Users+ -> ClientChannels+ -> [ChannelListEntry]+getSingleDMChannelEntries now config cconfig prefs us cs =+ let mapping = allDmChannelMappings cs+ mappingWithUserInfo = catMaybes $ getInfo <$> mapping+ getInfo (uId, cId) = do+ c <- findChannelById cId cs+ u <- findUserById uId us+ case u^.uiDeleted of+ True -> Nothing+ False ->+ if dmChannelShouldAppear now config prefs c+ then return (ChannelListEntry { channelListEntryChannelId = cId+ , channelListEntryType = CLUserDM uId+ , channelListEntryMuted = isMuted c+ , channelListEntryUnread = hasUnread' c+ , channelListEntrySortValue = displayNameForUser u cconfig prefs+ , channelListEntryFavorite = isFavorite prefs cId+ })+ else Nothing+ in mappingWithUserInfo++-- | Return whether the specified channel has been marked as a favorite+-- channel.+isFavorite :: UserPreferences -> ChannelId -> Bool+isFavorite prefs cId = favoriteChannelPreference prefs cId == Just True++-- Always show a DM channel if it has unread activity or has been marked+-- as a favorite.+--+-- If it has no unread activity and if the preferences explicitly say to+-- hide it, hide it.+--+-- Otherwise, only show it if at least one of the other conditions are+-- met (see 'or' below).+dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool+dmChannelShouldAppear now config prefs c =+ let ndays = configDirectChannelExpirationDays config+ localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now+ cutoff = ServerTime localCutoff+ updated = c^.ccInfo.cdUpdated+ uId = fromJust $ c^.ccInfo.cdDMUserId+ cId = c^.ccInfo.cdChannelId+ in if isFavorite prefs cId+ then True+ else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)+ then True+ else case dmChannelShowPreference prefs uId of+ Just False -> False+ _ -> or [+ -- The channel was updated recently enough+ updated >= cutoff+ ])++-- Always show a group DM channel if it has unread activity or has been+-- marked as a favorite.+--+-- If it has no unread activity and if the preferences explicitly say to+-- hide it, hide it.+--+-- Otherwise, only show it if at least one of the other conditions are+-- met (see 'or' below).+groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool+groupChannelShouldAppear now config prefs c =+ let ndays = configDirectChannelExpirationDays config+ localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now+ cutoff = ServerTime localCutoff+ updated = c^.ccInfo.cdUpdated+ cId = c^.ccInfo.cdChannelId+ in if isFavorite prefs cId+ then True+ else (if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)+ then True+ else case groupChannelShowPreference prefs cId of+ Just False -> False+ _ -> or [+ -- The channel was updated recently enough+ updated >= cutoff+ ])++dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool+dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps)++groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool+groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps)++favoriteChannelPreference :: UserPreferences -> ChannelId -> Maybe Bool+favoriteChannelPreference ps cId = HM.lookup cId (_userPrefFavoriteChannelPrefs ps)++-- | Types that provide a "semantically equal" operation. Two values may+-- be semantically equal even if they are not equal according to Eq if,+-- for example, they are equal on the basis of some fields that are more+-- pertinent than others.+class (Show a, Eq a, Ord a) => SemEq a where+ semeq :: a -> a -> Bool++instance SemEq Name where+ semeq (ClickableURL mId1 r1 _ t1) (ClickableURL mId2 r2 _ t2) = mId1 == mId2 && t1 == t2 && r1 == r2+ semeq (ClickableUsername mId1 r1 _ n) (ClickableUsername mId2 r2 _ n2) = mId1 == mId2 && n == n2 && r1 == r2+ semeq a b = a == b++instance SemEq a => SemEq (Maybe a) where+ semeq Nothing Nothing = True+ semeq (Just a) (Just b) = a `semeq` b+ semeq _ _ = False++-- | The sum type of exceptions we expect to encounter on authentication+-- failure. We encode them explicitly here so that we can print them in+-- a more user-friendly manner than just 'show'.+data AuthenticationException =+ ConnectError HostCannotConnect+ | ResolveError HostNotResolved+ | AuthIOError IOError+ | LoginError LoginFailureException+ | MattermostServerError MattermostError+ | OtherAuthError SomeException+ deriving (Show)++-- | Our 'ConnectionInfo' contains exactly as much information as is+-- necessary to start a connection with a Mattermost server. This is+-- built up during interactive authentication and then is used to log+-- in.+--+-- If the access token field is non-empty, that value is used and the+-- username and password values are ignored.+data ConnectionInfo =+ ConnectionInfo { _ciHostname :: Text+ , _ciPort :: Int+ , _ciUrlPath :: Text+ , _ciUsername :: Text+ , _ciOTPToken :: Maybe Text+ , _ciPassword :: Text+ , _ciAccessToken :: Text+ , _ciType :: ConnectionType+ }++-- | We want to continue referring to posts by their IDs, but we don't+-- want to have to synthesize new valid IDs for messages from the client+-- itself (like error messages or informative client responses). To that+-- end, a PostRef can be either a PostId or a newly-generated client ID.+data PostRef+ = MMId PostId+ | CLId Int+ deriving (Eq, Show)++-- ** Channel-matching types++data ChannelSelectPattern = CSP MatchType Text+ | CSPAny+ deriving (Eq, Show)++data MatchType =+ Prefix+ | Suffix+ | Infix+ | Equal+ | PrefixDMOnly+ | PrefixNonDMOnly+ deriving (Eq, Show)++-- * Application State Values++data ProgramOutput =+ ProgramOutput { program :: FilePath+ , programArgs :: [String]+ , programStdout :: String+ , programStderr :: String+ , programExitCode :: ExitCode+ }++defaultUserPreferences :: UserPreferences+defaultUserPreferences =+ UserPreferences { _userPrefShowJoinLeave = True+ , _userPrefFlaggedPostList = mempty+ , _userPrefGroupChannelPrefs = mempty+ , _userPrefDirectChannelPrefs = mempty+ , _userPrefFavoriteChannelPrefs = mempty+ , _userPrefTeammateNameDisplayMode = Nothing+ , _userPrefTeamOrder = Nothing+ }++setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences+setUserPreferences = flip (F.foldr go)+ where go p u+ | Just fp <- preferenceToFlaggedPost p =+ u { _userPrefFlaggedPostList =+ _userPrefFlaggedPostList u Seq.|> fp+ }+ | Just gp <- preferenceToDirectChannelShowStatus p =+ u { _userPrefDirectChannelPrefs =+ HM.insert+ (directChannelShowUserId gp)+ (directChannelShowValue gp)+ (_userPrefDirectChannelPrefs u)+ }+ | Just gp <- preferenceToGroupChannelPreference p =+ u { _userPrefGroupChannelPrefs =+ HM.insert+ (groupChannelId gp)+ (groupChannelShow gp)+ (_userPrefGroupChannelPrefs u)+ }+ | Just fp <- preferenceToFavoriteChannelPreference p =+ u { _userPrefFavoriteChannelPrefs =+ HM.insert+ (favoriteChannelId fp)+ (favoriteChannelShow fp)+ (_userPrefFavoriteChannelPrefs u)+ }+ | Just tIds <- preferenceToTeamOrder p =+ u { _userPrefTeamOrder = Just tIds+ }+ | preferenceName p == PreferenceName "join_leave" =+ u { _userPrefShowJoinLeave =+ preferenceValue p /= PreferenceValue "false" }+ | preferenceCategory p == PreferenceCategoryDisplaySettings &&+ preferenceName p == PreferenceName "name_format" =+ let PreferenceValue txt = preferenceValue p+ in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt }+ | otherwise = u++-- | Log message tags.+data LogCategory =+ LogGeneral+ | LogAPI+ | LogWebsocket+ | LogError+ | LogUserMark+ deriving (Eq, Show)++-- | A log message.+data LogMessage =+ LogMessage { logMessageText :: !Text+ -- ^ The text of the log message.+ , logMessageContext :: !(Maybe LogContext)+ -- ^ The optional context information relevant to the log+ -- message.+ , logMessageCategory :: !LogCategory+ -- ^ The category of the log message.+ , logMessageTimestamp :: !UTCTime+ -- ^ The timestamp of the log message.+ }+ deriving (Eq, Show)++-- | A logging thread command.+data LogCommand =+ LogToFile FilePath+ -- ^ Start logging to the specified path.+ | LogAMessage !LogMessage+ -- ^ Log the specified message.+ | StopLogging+ -- ^ Stop any active logging.+ | ShutdownLogging+ -- ^ Shut down.+ | GetLogDestination+ -- ^ Ask the logging thread about its active logging destination.+ | LogSnapshot FilePath+ -- ^ Ask the logging thread to dump the current buffer to the+ -- specified destination.+ deriving (Show)++-- | A handle to the log manager thread.+data LogManager =+ LogManager { logManagerCommandChannel :: STM.TChan LogCommand+ , logManagerHandle :: Async ()+ }++startLoggingToFile :: LogManager -> FilePath -> IO ()+startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc++stopLoggingToFile :: LogManager -> IO ()+stopLoggingToFile mgr = sendLogCommand mgr StopLogging++requestLogSnapshot :: LogManager -> FilePath -> IO ()+requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path++requestLogDestination :: LogManager -> IO ()+requestLogDestination mgr = sendLogCommand mgr GetLogDestination++sendLogMessage :: LogManager -> LogMessage -> IO ()+sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm++sendLogCommand :: LogManager -> LogCommand -> IO ()+sendLogCommand mgr c =+ STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c++-- | 'ChatResources' represents configuration and connection-related+-- information, as opposed to current model or view information.+-- Information that goes in the 'ChatResources' value should be limited+-- to information that we read or set up prior to setting up the bulk of+-- the application state.+data ChatResources =+ ChatResources { _crSession :: Session+ , _crWebsocketThreadId :: Maybe ThreadId+ , _crConn :: ConnectionData+ , _crRequestQueue :: RequestChan+ , _crEventQueue :: BCH.BChan MHEvent+ , _crSubprocessLog :: STM.TChan ProgramOutput+ , _crWebsocketActionChan :: STM.TChan WebsocketAction+ , _crTheme :: AttrMap+ , _crStatusUpdateChan :: STM.TChan [UserId]+ , _crConfiguration :: Config+ , _crFlaggedPosts :: Set PostId+ , _crUserPreferences :: UserPreferences+ , _crSyntaxMap :: SyntaxMap+ , _crLogManager :: LogManager+ , _crEmoji :: EmojiCollection+ , _crSpellChecker :: Maybe Aspell+ }++-- | The 'GlobalEditState' value contains state not specific to any+-- single editor.+data GlobalEditState =+ GlobalEditState { _gedYankBuffer :: Text+ }++emptyGlobalEditState :: GlobalEditState+emptyGlobalEditState =+ GlobalEditState { _gedYankBuffer = ""+ }++-- | A 'RequestChan' is a queue of operations we have to perform in the+-- background to avoid blocking on the main loop+type RequestChan = STM.TChan (IO (Maybe (MH ())))++-- | Help topics+data HelpTopic =+ HelpTopic { helpTopicName :: Text+ , helpTopicDescription :: Text+ , helpTopicScreen :: HelpScreen+ }+ deriving (Eq, Show)++-- | Mode type for the current contents of the post list window+data PostListContents =+ PostListFlagged+ | PostListPinned ChannelId+ | PostListSearch Text Bool -- for the query and search status+ deriving (Eq, Show)++-- | The 'Mode' represents the current dominant UI activity+data Mode =+ Main+ | ShowHelp HelpTopic+ | ChannelSelect+ | LeaveChannelConfirm+ | DeleteChannelConfirm+ | MessageSelectDeleteConfirm MessageInterfaceTarget+ | PostListWindow PostListContents+ | UserListWindow+ | ReactionEmojiListWindow+ | ChannelListWindow+ | ThemeListWindow+ | ViewMessage+ | EditNotifyPrefs+ | ChannelTopicWindow+ deriving (Eq, Show)++-- | We're either connected or we're not.+data ConnectionStatus = Connected | Disconnected deriving (Eq)++type ThreadInterface = MessageInterface Name PostId+type ChannelMessageInterface = MessageInterface Name ()++data ChannelListOrientation =+ ChannelListLeft+ -- ^ Show the channel list to the left of the message area.+ | ChannelListRight+ -- ^ Show the channel list to the right of the message area.+ deriving (Eq, Show)++data ThreadOrientation =+ ThreadBelow+ -- ^ Show the thread below the channel message area.+ | ThreadAbove+ -- ^ Show the thread above the channel message area.+ | ThreadLeft+ -- ^ Show the thread to the left of the channel message area.+ | ThreadRight+ -- ^ Show the thread to the right of the channel message area.+ deriving (Eq, Show)++-- | This type represents the current state of our application at any+-- given time.+data ChatState =+ ChatState { _csResources :: ChatResources+ -- ^ Global application-wide resources that don't change+ -- much.+ , _csLastMouseDownEvent :: Maybe (Brick.BrickEvent Name MHEvent)+ -- ^ The most recent mouse click event we got. We reset+ -- this on mouse up so we can ignore clicks whenever this+ -- is already set.+ , _csVerbatimTruncateSetting :: Maybe Int+ -- ^ The current verbatim block truncation setting. This+ -- is used to toggle truncation behavior and is updated+ -- from the configTruncateVerbatimBlocks Config field.+ , _csTeams :: HashMap TeamId TeamState+ -- ^ The state for each team that we are in.+ , _csTeamZipper :: Z.Zipper () TeamId+ -- ^ The list of teams we can cycle through.+ , _csChannelListOrientation :: ChannelListOrientation+ -- ^ The orientation of the channel list.+ , _csMe :: User+ -- ^ The authenticated user.+ , _csChannels :: ClientChannels+ -- ^ The channels that we are showing, including their+ -- message lists.+ , _csHiddenChannelGroups :: HM.HashMap TeamId (Set ChannelListGroupLabel)+ -- ^ The set of channel list groups that are currently+ -- collapsed in the sidebar.+ , _csPostMap :: HashMap PostId Message+ -- ^ The map of post IDs to messages. This allows us to+ -- access messages by ID without having to linearly scan+ -- channel message lists.+ , _csUsers :: Users+ -- ^ All of the users we know about.+ , _timeZone :: TimeZoneSeries+ -- ^ The client time zone.+ , _csConnectionStatus :: ConnectionStatus+ -- ^ Our view of the connection status.+ , _csWorkerIsBusy :: Maybe (Maybe Int)+ -- ^ Whether the async worker thread is busy, and its+ -- queue length if so.+ , _csClientConfig :: Maybe ClientConfig+ -- ^ The Mattermost client configuration, as we understand it.+ , _csInputHistory :: InputHistory+ -- ^ The map of per-channel input history for the+ -- application. We don't distribute the per-channel+ -- history into the per-channel states (like we do+ -- for other per-channel state) since keeping it+ -- under the InputHistory banner lets us use a nicer+ -- startup/shutdown disk file management API.+ , _csGlobalEditState :: GlobalEditState+ -- ^ Bits of global state common to all editors.+ }++-- | All application state specific to a team, along with state specific+-- to our user interface's presentation of that team. We include the+-- UI state relevant to the team so that we can easily switch which+-- team the UI is presenting without having to reinitialize the UI from+-- the new team. This allows the user to be engaged in just about any+-- application activity while viewing a team, switch to another team,+-- and return to the original team and resume what they were doing, all+-- without us doing any work.+data TeamState =+ TeamState { _tsFocus :: Z.Zipper ChannelListGroup ChannelListEntry+ -- ^ The channel sidebar zipper that tracks which channel+ -- is selected.+ , _tsTeam :: Team+ -- ^ The team data.+ , _tsRecentChannel :: Maybe ChannelId+ -- ^ The most recently-selected channel, if any.+ , _tsReturnChannel :: Maybe ChannelId+ -- ^ The channel to return to after visiting one or more+ -- unread channels.+ , _tsModeStack :: NonemptyStack Mode+ -- ^ The current application mode stack when viewing this+ -- team. This is used to dispatch to different rendering+ -- and event handling routines. The current mode is always+ -- in at the top of the stack.+ , _tsChannelSelectState :: ChannelSelectState+ -- ^ The state of the user's input and selection for+ -- channel selection mode.+ , _tsPendingChannelChange :: Maybe PendingChannelChange+ -- ^ A pending channel change that we need to apply once+ -- the channel in question is available. We set this up+ -- when we need to change to a channel in the sidebar, but+ -- it isn't even there yet because we haven't loaded its+ -- metadata.+ , _tsViewedMessage :: Maybe (Message, TabbedWindow ChatState MH Name ViewMessageWindowTab)+ -- ^ Set when the ViewMessage mode is active. The message+ -- being viewed. Note that this stores a message, not+ -- a message ID. That's because not all messages have+ -- message IDs (e.g. client messages) and we still+ -- want to support viewing of those messages. It's the+ -- responsibility of code that uses this message to always+ -- consult the chat state for the latest *version* of any+ -- message with an ID here, to be sure that the latest+ -- version is used (e.g. if it gets edited, etc.).+ , _tsPostListWindow :: PostListWindowState+ -- ^ The state of the post list window.+ , _tsUserListWindow :: ListWindowState UserInfo UserSearchScope+ -- ^ The state of the user list window.+ , _tsChannelListWindow :: ListWindowState Channel ChannelSearchScope+ -- ^ The state of the user list window.+ , _tsNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name)+ -- ^ A form for editing the notification preferences for+ -- the current channel. This is set when entering+ -- EditNotifyPrefs mode and updated when the user+ -- changes the form state.+ , _tsChannelTopicDialog :: ChannelTopicDialogState+ -- ^ The state for the interactive channel topic editor+ -- window.+ , _tsReactionEmojiListWindow :: ListWindowState (Bool, T.Text) ()+ -- ^ The state of the reaction emoji list window.+ , _tsThemeListWindow :: ListWindowState InternalTheme ()+ -- ^ The state of the theme list window.+ , _tsChannelListSorting :: ChannelListSorting+ -- ^ How to sort channels in this team's channel list+ -- groups+ , _tsThreadInterface :: Maybe ThreadInterface+ -- ^ The thread interface for this team for participating+ -- in a single thread+ , _tsMessageInterfaceFocus :: MessageInterfaceFocus+ -- ^ Which message interface is focused for editing input+ }++data MessageInterfaceFocus =+ FocusThread+ | FocusCurrentChannel+ deriving (Eq, Show)++messageInterfaceFocusList :: [MessageInterfaceFocus]+messageInterfaceFocusList =+ [ FocusCurrentChannel+ , FocusThread+ ]++messageInterfaceFocusNext :: TeamState -> TeamState+messageInterfaceFocusNext = messageInterfaceFocusWith messageInterfaceFocusList++messageInterfaceFocusPrev :: TeamState -> TeamState+messageInterfaceFocusPrev = messageInterfaceFocusWith (reverse messageInterfaceFocusList)++messageInterfaceFocusWith :: [MessageInterfaceFocus] -> TeamState -> TeamState+messageInterfaceFocusWith lst ts =+ let next = fromJust $ cycleElemAfter cur lst+ cur = _tsMessageInterfaceFocus ts+ noThread = isNothing $ _tsThreadInterface ts+ newFocus = if next == FocusThread && noThread+ then fromJust $ cycleElemAfter FocusThread lst+ else next+ in ts { _tsMessageInterfaceFocus = newFocus }++cycleElemAfter :: (Eq a) => a -> [a] -> Maybe a+cycleElemAfter e es =+ if e `notElem` es+ then Nothing+ else Just $ head $ drop 1 $ dropWhile (/= e) $ cycle es++-- | Handles for the View Message window's tabs.+data ViewMessageWindowTab =+ VMTabMessage+ -- ^ The message tab.+ | VMTabReactions+ -- ^ The reactions tab.+ deriving (Eq, Show)++data PendingChannelChange =+ ChangeByChannelId TeamId ChannelId (Maybe (MH ()))+ | ChangeByUserId UserId++-- | Startup state information that is constructed prior to building a+-- ChatState.+data StartupStateInfo =+ StartupStateInfo { startupStateResources :: ChatResources+ , startupStateConnectedUser :: User+ , startupStateTeams :: HM.HashMap TeamId TeamState+ , startupStateTimeZone :: TimeZoneSeries+ , startupStateInitialHistory :: InputHistory+ , startupStateInitialTeam :: TeamId+ }++-- | The state of the channel topic editor window.+data ChannelTopicDialogState =+ ChannelTopicDialogState { _channelTopicDialogEditor :: Editor T.Text Name+ -- ^ The topic string editor state.+ , _channelTopicDialogFocus :: FocusRing Name+ -- ^ The window focus state (editor/buttons)+ }++sortTeams :: [Team] -> [Team]+sortTeams = sortBy (compare `on` (T.strip . sanitizeUserText . teamName))++matchesTeam :: T.Text -> Team -> Bool+matchesTeam tName t =+ let normalizeUserText = normalize . sanitizeUserText+ normalize = T.strip . T.toLower+ urlName = normalizeUserText $ teamName t+ displayName = normalizeUserText $ teamDisplayName t+ in normalize tName `elem` [displayName, urlName]++mkTeamZipper :: HM.HashMap TeamId TeamState -> Z.Zipper () TeamId+mkTeamZipper m =+ let sortedTeams = sortTeams $ _tsTeam <$> HM.elems m+ in mkTeamZipperFromIds $ teamId <$> sortedTeams++mkTeamZipperFromIds :: [TeamId] -> Z.Zipper () TeamId+mkTeamZipperFromIds tIds = Z.fromList [((), tIds)]++teamZipperIds :: Z.Zipper () TeamId -> [TeamId]+teamZipperIds = concat . fmap snd . Z.toList++-- | The state of channel selection mode.+data ChannelSelectState =+ ChannelSelectState { _channelSelectInput :: Editor Text Name+ , _channelSelectMatches :: Z.Zipper ChannelListGroup ChannelSelectMatch+ }++emptyChannelSelectState :: TeamId -> ChannelSelectState+emptyChannelSelectState tId =+ ChannelSelectState { _channelSelectInput = editor (ChannelSelectInput tId) (Just 1) ""+ , _channelSelectMatches = Z.fromList []+ }++-- | The state of the post list window.+data PostListWindowState =+ PostListWindowState { _postListPosts :: Messages+ , _postListSelected :: Maybe PostId+ }++data InternalTheme =+ InternalTheme { internalThemeName :: Text+ , internalTheme :: Theme+ , internalThemeDesc :: Text+ }++-- | The state of the search result list window. Type 'a' is the type+-- of data in the list. Type 'b' is the search scope type.+data ListWindowState a b =+ ListWindowState { _listWindowSearchResults :: List Name a+ -- ^ The list of search results currently shown in+ -- the window.+ , _listWindowSearchInput :: Editor Text Name+ -- ^ The editor for the window's search input.+ , _listWindowSearchScope :: b+ -- ^ The window's current search scope.+ , _listWindowSearching :: Bool+ -- ^ Whether a search is in progress (i.e. whether+ -- we are currently awaiting a response from a+ -- search query to the server).+ , _listWindowEnterHandler :: a -> MH Bool+ -- ^ The handler to invoke on the selected element+ -- when the user presses Enter.+ , _listWindowNewList :: Vec.Vector a -> List Name a+ -- ^ The function to build a new brick List from a+ -- vector of search results.+ , _listWindowFetchResults :: b -> Session -> Text -> IO (Vec.Vector a)+ -- ^ The function to call to issue a search query+ -- to the server.+ , _listWindowRecordCount :: Maybe Int+ -- ^ The total number of available records, if known.+ }++-- | The scope for searching for users in a user list window.+data UserSearchScope =+ ChannelMembers ChannelId TeamId+ | ChannelNonMembers ChannelId TeamId+ | AllUsers (Maybe TeamId)++-- | The scope for searching for channels to join.+data ChannelSearchScope =+ AllChannels++-- | Actions that can be sent on the websocket to the server.+data WebsocketAction =+ UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box+ deriving (Read, Show, Eq, Ord)++-- * MH Monad++-- | Logging context information, in the event that metadata should+-- accompany a log message.+data LogContext =+ LogContext { logContextChannelId :: Maybe ChannelId+ }+ deriving (Eq, Show)++-- | A user fetching strategy.+data UserFetch =+ UserFetchById UserId+ -- ^ Fetch the user with the specified ID.+ | UserFetchByUsername Text+ -- ^ Fetch the user with the specified username.+ | UserFetchByNickname Text+ -- ^ Fetch the user with the specified nickname.+ deriving (Eq, Show)++data MHState =+ MHState { mhCurrentState :: ChatState+ , mhNextAction :: ChatState -> EventM Name (Next ChatState)+ , mhUsersToFetch :: [UserFetch]+ , mhPendingStatusList :: Maybe [UserId]+ }++-- | A value of type 'MH' @a@ represents a computation that can+-- manipulate the application state and also request that the+-- application quit+newtype MH a =+ MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name)) a }++-- | Use a modified logging context for the duration of the specified MH+-- action.+withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a+withLogContext modifyContext act =+ MH $ R.withReaderT modifyContext (fromMH act)++withLogContextChannelId :: ChannelId -> MH a -> MH a+withLogContextChannelId cId act =+ let f Nothing = Just $ LogContext (Just cId)+ f (Just c) = Just $ c { logContextChannelId = Just cId }+ in withLogContext f act++-- | Get the current logging context.+getLogContext :: MH (Maybe LogContext)+getLogContext = MH R.ask++-- | Log a message.+mhLog :: LogCategory -> Text -> MH ()+mhLog cat msg = do+ logger <- mhGetIOLogger+ liftIO $ logger cat msg++-- | Get a logger suitable for use in IO. The logger always logs using+-- the MH monad log context at the time of the call to mhGetIOLogger.+mhGetIOLogger :: MH (LogCategory -> Text -> IO ())+mhGetIOLogger = do+ ctx <- getLogContext+ mgr <- use (to (_crLogManager . _csResources))+ return $ ioLogWithManager mgr ctx++ioLogWithManager :: LogManager -> Maybe LogContext -> LogCategory -> Text -> IO ()+ioLogWithManager mgr ctx cat msg = do+ now <- getCurrentTime+ let lm = LogMessage { logMessageText = msg+ , logMessageContext = ctx+ , logMessageCategory = cat+ , logMessageTimestamp = now+ }+ sendLogMessage mgr lm++-- | Run an 'MM' computation, choosing whether to continue or halt based+-- on the resulting+runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState)+runMHEvent st (MH mote) = do+ let mhSt = MHState { mhCurrentState = st+ , mhNextAction = Brick.continue+ , mhUsersToFetch = []+ , mhPendingStatusList = Nothing+ }+ ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt+ (mhNextAction st') (mhCurrentState st')++scheduleUserFetches :: [UserFetch] -> MH ()+scheduleUserFetches fs = MH $ do+ St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s }++scheduleUserStatusFetches :: [UserId] -> MH ()+scheduleUserStatusFetches is = MH $ do+ St.modify $ \s -> s { mhPendingStatusList = Just is }++getScheduledUserFetches :: MH [UserFetch]+getScheduledUserFetches = MH $ St.gets mhUsersToFetch++getScheduledUserStatusFetches :: MH (Maybe [UserId])+getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList++-- | lift a computation in 'EventM' into 'MH'+mh :: EventM Name a -> MH a+mh = MH . R.lift . St.lift++generateUUID :: MH UUID+generateUUID = liftIO generateUUID_IO++generateUUID_IO :: IO UUID+generateUUID_IO = randomIO++mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH ()+mhHandleEventLensed ln f event = MH $ do+ s <- St.get+ let st = mhCurrentState s+ n <- R.lift $ St.lift $ f event (st ^. ln)+ St.put (s { mhCurrentState = st & ln .~ n })++mhHandleEventLensed' :: Lens' ChatState b -> (b -> EventM Name b) -> MH ()+mhHandleEventLensed' ln f = MH $ do+ s <- St.get+ let st = mhCurrentState s+ n <- R.lift $ St.lift $ f (st ^. ln)+ St.put (s { mhCurrentState = st & ln .~ n })++mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()+mhSuspendAndResume mote = MH $ do+ s <- St.get+ St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) }++mhContinueWithoutRedraw :: MH ()+mhContinueWithoutRedraw = MH $ do+ s <- St.get+ St.put $ s { mhNextAction = \ _ -> Brick.continueWithoutRedraw (mhCurrentState s) }++-- | This will request that after this computation finishes the+-- application should exit+requestQuit :: MH ()+requestQuit = MH $ do+ s <- St.get+ St.put $ s { mhNextAction = Brick.halt }++instance Functor MH where+ fmap f (MH x) = MH (fmap f x)++instance Applicative MH where+ pure x = MH (pure x)+ MH f <*> MH x = MH (f <*> x)++instance MHF.MonadFail MH where+ fail = MH . MHF.fail++instance Monad MH where+ return = pure+ MH x >>= f = MH (x >>= \ x' -> fromMH (f x'))++-- We want to pretend that the state is only the ChatState, rather+-- than the ChatState and the Brick continuation+instance St.MonadState ChatState MH where+ get = mhCurrentState `fmap` MH St.get+ put st = MH $ do+ s <- St.get+ St.put $ s { mhCurrentState = st }++instance St.MonadIO MH where+ liftIO = MH . St.liftIO++-- | This represents events that we handle in the main application loop.+data MHEvent =+ WSEvent WebsocketEvent+ -- ^ For events that arise from the websocket+ | WSActionResponse WebsocketActionResponse+ -- ^ For responses to websocket actions+ | RespEvent (MH ())+ -- ^ For the result values of async IO operations+ | RefreshWebsocketEvent+ -- ^ Tell our main loop to refresh the websocket connection+ | WebsocketParseError String+ -- ^ We failed to parse an incoming websocket event+ | WebsocketDisconnect+ -- ^ The websocket connection went down.+ | WebsocketConnect+ -- ^ The websocket connection came up.+ | BGIdle+ -- ^ background worker is idle+ | BGBusy (Maybe Int)+ -- ^ background worker is busy (with n requests)+ | RateLimitExceeded Int+ -- ^ A request initially failed due to a rate limit but will be+ -- retried if possible. The argument is the number of seconds in+ -- which the retry will be attempted.+ | RateLimitSettingsMissing+ -- ^ A request denied by a rate limit could not be retried because+ -- the response contained no rate limit metadata+ | RequestDropped+ -- ^ A request was reattempted due to a rate limit and was rate+ -- limited again+ | IEvent InternalEvent+ -- ^ MH-internal events++-- | Internal application events.+data InternalEvent =+ DisplayError MHError+ -- ^ Some kind of application error occurred+ | LoggingStarted FilePath+ | LoggingStopped FilePath+ | LogStartFailed FilePath String+ | LogDestination (Maybe FilePath)+ | LogSnapshotSucceeded FilePath+ | LogSnapshotFailed FilePath String+ -- ^ Logging events from the logging thread++-- | Application errors.+data MHError =+ GenericError T.Text+ -- ^ A generic error message constructor+ | NoSuchChannel T.Text+ -- ^ The specified channel does not exist+ | NoSuchUser T.Text+ -- ^ The specified user does not exist+ | AmbiguousName T.Text+ -- ^ The specified name matches both a user and a channel+ | ServerError MattermostError+ -- ^ A Mattermost server error occurred+ | ClipboardError T.Text+ -- ^ A problem occurred trying to deal with yanking or the system+ -- clipboard+ | ConfigOptionMissing T.Text+ -- ^ A missing config option is required to perform an operation+ | ProgramExecutionFailed T.Text T.Text+ -- ^ Args: program name, path to log file. A problem occurred when+ -- running the program.+ | NoSuchScript T.Text+ -- ^ The specified script was not found+ | NoSuchHelpTopic T.Text+ -- ^ The specified help topic was not found+ | AttachmentException SomeException+ -- ^ IO operations for attaching a file threw an exception+ | BadAttachmentPath T.Text+ -- ^ The specified file is either a directory or doesn't exist+ | AsyncErrEvent SomeException+ -- ^ For errors that arise in the course of async IO operations+ deriving (Show)++-- ** Application State Lenses++makeLenses ''ChatResources+makeLenses ''ChatState+makeLenses ''TeamState+makeLenses ''GlobalEditState+makeLenses ''PostListWindowState+makeLenses ''ListWindowState+makeLenses ''ChannelSelectState+makeLenses ''UserPreferences+makeLenses ''ConnectionInfo+makeLenses ''ChannelTopicDialogState+Brick.suffixLenses ''Config++-- | Given a list of event handlers and an event, try to handle the+-- event with the handlers in the specified order. If a handler returns+-- False (indicating it did not handle the event), try the next handler+-- until either a handler returns True or all handlers are tried.+-- Returns True if any handler handled the event or False otherwise.+handleEventWith :: [Vty.Event -> MH Bool] -> Vty.Event -> MH Bool+handleEventWith [] _ =+ return False+handleEventWith (handler:rest) e = do+ handled <- handler e+ if handled+ then return True+ else handleEventWith rest e++applyTeamOrderPref :: Maybe [TeamId] -> ChatState -> ChatState+applyTeamOrderPref Nothing st = st+applyTeamOrderPref (Just prefTIds) st =+ let teams = _csTeams st+ ourTids = HM.keys teams+ tIds = filter (`elem` ourTids) prefTIds+ curTId = st^.csCurrentTeamId+ unmentioned = filter (not . wasMentioned) $ HM.elems teams+ wasMentioned ts = (teamId $ _tsTeam ts) `elem` tIds+ zipperTids = tIds <> (teamId <$> sortTeams (_tsTeam <$> unmentioned))+ in st { _csTeamZipper = (Z.findRight ((== curTId) . Just) $ mkTeamZipperFromIds zipperTids)+ }++refreshTeamZipper :: MH ()+refreshTeamZipper = do+ tidOrder <- use (csResources.crUserPreferences.userPrefTeamOrder)+ St.modify (applyTeamOrderPref tidOrder)++applyTeamOrder :: [TeamId] -> MH ()+applyTeamOrder tIds = St.modify (applyTeamOrderPref $ Just tIds)++newState :: StartupStateInfo -> ChatState+newState (StartupStateInfo {..}) =+ let config = _crConfiguration startupStateResources+ in applyTeamOrderPref (_userPrefTeamOrder $ _crUserPreferences startupStateResources) $+ ChatState { _csResources = startupStateResources+ , _csLastMouseDownEvent = Nothing+ , _csGlobalEditState = emptyGlobalEditState+ , _csVerbatimTruncateSetting = configTruncateVerbatimBlocks config+ , _csTeamZipper = Z.findRight (== startupStateInitialTeam) $+ mkTeamZipper startupStateTeams+ , _csTeams = startupStateTeams+ , _csChannelListOrientation = configChannelListOrientation config+ , _csMe = startupStateConnectedUser+ , _csChannels = noChannels+ , _csPostMap = HM.empty+ , _csUsers = noUsers+ , _timeZone = startupStateTimeZone+ , _csConnectionStatus = Connected+ , _csWorkerIsBusy = Nothing+ , _csClientConfig = Nothing+ , _csInputHistory = startupStateInitialHistory+ , _csHiddenChannelGroups = mempty+ }++getServerBaseUrl :: TeamId -> MH TeamBaseURL+getServerBaseUrl tId = do+ st <- use id+ return $ serverBaseUrl st tId++serverBaseUrl :: ChatState -> TeamId -> TeamBaseURL+serverBaseUrl st tId =+ let baseUrl = connectionDataURL $ _crConn $ _csResources st+ tName = teamName $ st^.csTeam(tId).tsTeam+ in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl++getSession :: MH Session+getSession = use (csResources.crSession)++getResourceSession :: ChatResources -> Session+getResourceSession = _crSession++whenMode :: TeamId -> Mode -> MH () -> MH ()+whenMode tId m act = do+ curMode <- top <$> use (csTeam(tId).tsModeStack)+ when (curMode == m) act++pushMode :: TeamId -> Mode -> MH ()+pushMode tId m = do+ St.modify (pushMode' tId m)+ mh invalidateCache++replaceMode :: TeamId -> Mode -> MH ()+replaceMode tId m = popMode tId >> pushMode tId m++popMode :: TeamId -> MH ()+popMode tId = do+ s <- use (csTeam(tId).tsModeStack)+ let (s', topVal) = pop s+ case topVal of+ Nothing -> return ()+ Just _ -> do+ csTeam(tId).tsModeStack .= s'+ mh invalidateCache++pushMode' :: TeamId -> Mode -> ChatState -> ChatState+pushMode' tId m st =+ let s = st^.csTeam(tId).tsModeStack+ in if top s == m+ then st+ else st & csTeam(tId).tsModeStack %~ (push m)++-- ** Utility Lenses+csCurrentChannelId :: TeamId -> SimpleGetter ChatState (Maybe ChannelId)+csCurrentChannelId tId =+ csTeam(tId).tsFocus.to Z.focus.to (fmap channelListEntryChannelId)++withCurrentTeam :: (TeamId -> MH ()) -> MH ()+withCurrentTeam f = do+ mtId <- use csCurrentTeamId+ case mtId of+ Nothing -> return ()+ Just tId -> f tId++withCurrentChannel :: TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()+withCurrentChannel tId f = do+ mcId <- use $ csCurrentChannelId tId+ case mcId of+ Nothing -> return ()+ Just cId -> do+ mChan <- preuse $ csChannel cId+ case mChan of+ Just ch -> f cId ch+ _ -> return ()++withCurrentChannel' :: TeamId -> (ChannelId -> ClientChannel -> MH (Maybe a)) -> MH (Maybe a)+withCurrentChannel' tId f = do+ mcId <- use $ csCurrentChannelId tId+ case mcId of+ Nothing -> return Nothing+ Just cId -> do+ mChan <- preuse $ csChannel cId+ case mChan of+ Just ch -> f cId ch+ _ -> return Nothing++csCurrentTeamId :: SimpleGetter ChatState (Maybe TeamId)+csCurrentTeamId = csTeamZipper.to Z.focus++csChannelMessageInterface :: ChannelId -> Lens' ChatState ChannelMessageInterface+csChannelMessageInterface cId =+ csChannels.maybeChannelByIdL cId.singular _Just.ccMessageInterface++maybeChannelMessageInterface :: ChannelId -> Traversal' ChatState ChannelMessageInterface+maybeChannelMessageInterface cId =+ csChannels.maybeChannelByIdL cId._Just.ccMessageInterface++channelEditor :: ChannelId -> Lens' ChatState (EditState Name)+channelEditor cId =+ csChannels.maybeChannelByIdL cId.singular _Just.ccMessageInterface.miEditor++channelMessageSelect :: ChannelId -> Lens' ChatState MessageSelectState+channelMessageSelect cId =+ csChannels.maybeChannelByIdL cId.singular _Just.ccMessageInterface.miMessageSelect++csTeam :: TeamId -> Lens' ChatState TeamState+csTeam tId =+ lens (\ st -> st ^. csTeams . at tId ^?! _Just)+ (\ st t -> st & csTeams . at tId .~ Just t)++teamMode :: TeamState -> Mode+teamMode = top . _tsModeStack++teamModes :: TeamState -> [Mode]+teamModes = stackToList . _tsModeStack++getTeamMode :: TeamId -> MH Mode+getTeamMode tId = teamMode <$> use (csTeam(tId))++channelListEntryUserId :: ChannelListEntry -> Maybe UserId+channelListEntryUserId e =+ case channelListEntryType e of+ CLUserDM uId -> Just uId+ _ -> Nothing++userIdsFromZipper :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId]+userIdsFromZipper z =+ concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.toList z++entryIsDMEntry :: ChannelListEntry -> Bool+entryIsDMEntry e =+ case channelListEntryType e of+ CLUserDM {} -> True+ CLGroupDM {} -> True+ CLChannel {} -> False++csChannel :: ChannelId -> Traversal' ChatState ClientChannel+csChannel cId =+ csChannels . channelByIdL cId++csChannelMessages :: ChannelId -> Traversal' ChatState Messages+csChannelMessages cId =+ csChannelMessageInterface(cId).miMessages++withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH ()+withChannel cId = withChannelOrDefault cId ()++withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a+withChannelOrDefault cId deflt mote = do+ chan <- preuse (csChannel(cId))+ case chan of+ Nothing -> return deflt+ Just c -> mote c++-- ** 'ChatState' Helper Functions++raiseInternalEvent :: InternalEvent -> MH ()+raiseInternalEvent ev = do+ queue <- use (csResources.crEventQueue)+ writeBChan queue (IEvent ev)++writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m ()+writeBChan chan e = do+ written <- liftIO $ BCH.writeBChanNonBlocking chan e+ when (not written) $+ error $ "mhSendEvent: BChan full, please report this as a bug!"++-- | Log and raise an error.+mhError :: MHError -> MH ()+mhError err = do+ mhLog LogError $ T.pack $ show err+ raiseInternalEvent (DisplayError err)++isMine :: ChatState -> Message -> Bool+isMine st msg =+ case msg^.mUser of+ UserI _ uid -> uid == myUserId st+ _ -> False++getMessageForPostId :: ChatState -> PostId -> Maybe Message+getMessageForPostId st pId = st^.csPostMap.at(pId)++getParentMessage :: ChatState -> Message -> Maybe Message+getParentMessage st msg+ | InReplyTo pId <- msg^.mInReplyToMsg+ = st^.csPostMap.at(pId)+ | otherwise = Nothing++getReplyRootMessage :: Message -> MH Message+getReplyRootMessage msg = do+ case postRootId =<< (msg^.mOriginalPost) of+ Nothing -> return msg+ Just rootId -> do+ st <- use id+ case getMessageForPostId st rootId of+ -- NOTE: this case should never happen. This is the+ -- case where a message has a root post ID but we+ -- don't have a copy of the root post in storage. This+ -- shouldn't happen because whenever we add a message+ -- to a channel, we always fetch the parent post and+ -- store it if it is in a thread. That should mean that+ -- whenever we reply to a post, if that post is itself+ -- a reply, we should have its root post in storage+ -- and this case should never match. Even though it+ -- shouldn't happen, rather than raising a BUG exception+ -- here we'll just fall back to the input message.+ Nothing -> return msg+ Just m -> return m++setUserStatus :: UserId -> Text -> MH ()+setUserStatus uId t = do+ csUsers %= modifyUserById uId (uiStatus .~ statusFromText t)+ cs <- use csChannels+ forM_ (allTeamIds cs) $ \tId ->+ mh $ invalidateCacheEntry $ ChannelSidebar tId++usernameForUserId :: UserId -> ChatState -> Maybe Text+usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers)++displayNameForUserId :: UserId -> ChatState -> Maybe Text+displayNameForUserId uId st = do+ u <- findUserById uId (st^.csUsers)+ return $ displayNameForUser u (st^.csClientConfig) (st^.csResources.crUserPreferences)++-- | Note: this only searches users we have already loaded. Be+-- aware that if you think you need a user we haven't fetched, use+-- withFetchedUser!+userIdForUsername :: Text -> ChatState -> Maybe UserId+userIdForUsername name st =+ fst <$> (findUserByUsername name $ st^.csUsers)++channelIdByChannelName :: TeamId -> Text -> ChatState -> Maybe ChannelId+channelIdByChannelName tId name st =+ let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name) &&+ cc^.ccInfo.cdTeamId == (Just tId)+ in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels)++channelIdByUsername :: Text -> ChatState -> Maybe ChannelId+channelIdByUsername name st = do+ uId <- userIdForUsername name st+ getDmChannelFor uId (st^.csChannels)++useNickname :: ChatState -> Bool+useNickname st =+ useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences)++trimChannelSigil :: Text -> Text+trimChannelSigil n+ | normalChannelSigil `T.isPrefixOf` n = T.tail n+ | otherwise = n++addNewUser :: UserInfo -> MH ()+addNewUser u = do+ csUsers %= addUser u+ -- Invalidate the cache because channel message rendering may need+ -- to get updated if this user authored posts in any channels.+ mh invalidateCache++data SidebarUpdate =+ SidebarUpdateImmediate+ | SidebarUpdateDeferred+ deriving (Eq, Show)+++resetAutocomplete :: Traversal' ChatState (EditState n) -> MH ()+resetAutocomplete which = do+ which.esAutocomplete .= Nothing+ which.esAutocompletePending .= Nothing+++-- * Slash Commands++-- | The 'CmdArgs' type represents the arguments to a slash-command; the+-- type parameter represents the argument structure.+data CmdArgs :: K.Type -> K.Type where+ NoArg :: CmdArgs ()+ LineArg :: Text -> CmdArgs Text+ UserArg :: CmdArgs rest -> CmdArgs (Text, rest)+ ChannelArg :: CmdArgs rest -> CmdArgs (Text, rest)+ TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest)++-- | A 'CmdExec' value represents the implementation of a command when+-- provided with its arguments+type CmdExec a = a -> MH ()++-- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec'+-- implementation with a name and a description.+data Cmd =+ forall a. Cmd { cmdName :: Text+ , cmdDescr :: Text+ , cmdArgSpec :: CmdArgs a+ , cmdAction :: CmdExec a+ }++-- | Helper function to extract the name out of a 'Cmd' value+commandName :: Cmd -> Text+commandName (Cmd name _ _ _ ) = name++-- * Channel Updates and Notifications++userList :: ChatState -> [UserInfo]+userList st = filter showUser $ allUsers (st^.csUsers)+ where showUser u = not (isSelf u) && (u^.uiInTeam)+ isSelf u = (myUserId st) == (u^.uiId)++allUserIds :: ChatState -> [UserId]+allUserIds st = getAllUserIds $ st^.csUsers++-- BEWARE: you probably don't want this, but instead+-- State.Users.withFetchedUser, since this only looks up users in the+-- collection we have already loaded rather than all valid users on the+-- server.+userById :: UserId -> ChatState -> Maybe UserInfo+userById uId st = findUserById uId (st^.csUsers)++myUserId :: ChatState -> UserId+myUserId st = myUser st ^. userIdL++myUser :: ChatState -> User+myUser st = st^.csMe++myUsername :: ChatState -> Text+myUsername st = userUsername $ st^.csMe++-- BEWARE: you probably don't want this, but instead+-- State.Users.withFetchedUser, since this only looks up users in the+-- collection we have already loaded rather than all valid users on the+-- server.+userByUsername :: Text -> ChatState -> Maybe UserInfo+userByUsername name st = do+ snd <$> (findUserByUsername name $ st^.csUsers)++-- BEWARE: you probably don't want this, but instead+-- State.Users.withFetchedUser, since this only looks up users in the+-- collection we have already loaded rather than all valid users on the+-- server.+userByNickname :: Text -> ChatState -> Maybe UserInfo+userByNickname name st =+ snd <$> (findUserByNickname name $ st^.csUsers)++getUsers :: MH Users+getUsers = use csUsers++-- * HighlightSet++type UserSet = Set Text+type ChannelSet = Set Text++-- | The set of usernames, channel names, and language names used for+-- highlighting when rendering messages.+data HighlightSet =+ HighlightSet { hUserSet :: Set Text+ , hChannelSet :: Set Text+ , hSyntaxMap :: SyntaxMap+ }++emptyHSet :: HighlightSet+emptyHSet = HighlightSet Set.empty Set.empty mempty++getHighlightSet :: ChatState -> TeamId -> HighlightSet+getHighlightSet st tId =+ HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers+ , hChannelSet = getChannelNameSet tId $ st^.csChannels+ , hSyntaxMap = st^.csResources.crSyntaxMap+ }++attrNameToConfig :: Brick.AttrName -> Text+attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents++-- From: https://docs.mattermost.com/help/messaging/mentioning-teammates.html+specialUserMentions :: [T.Text]+specialUserMentions = ["all", "channel", "here"]++addSpecialUserMentions :: Set Text -> Set Text+addSpecialUserMentions s = foldr Set.insert s specialUserMentions++getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator+getNewMessageCutoff cId st = do+ cc <- st^?csChannel(cId)+ return $ cc^.ccInfo.cdNewMessageIndicator++getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime+getEditedMessageCutoff cId st = do+ cc <- st^?csChannel(cId)+ cc^.ccInfo.cdEditedMessageThreshold++clearChannelUnreadStatus :: ChannelId -> MH ()+clearChannelUnreadStatus cId = do+ mh $ invalidateCacheEntry (MessageInterfaceMessages $ MessageInput cId)+ csChannel(cId) %= (clearNewMessageIndicator .+ clearEditedThreshold)++moveLeft :: (Eq a) => a -> [a] -> [a]+moveLeft v as =+ case elemIndex v as of+ Nothing -> as+ Just 0 -> as+ Just i ->+ let (h, t) = splitAt i as+ in init h <> [v, last h] <> tail t++moveRight :: (Eq a) => a -> [a] -> [a]+moveRight v as =+ case elemIndex v as of+ Nothing -> as+ Just i+ | i == length as - 1 -> as+ | otherwise ->+ let (h, t) = splitAt i as+ in h <> [head (tail t), v] <> (tail (tail t))++resultToWidget :: Result n -> Widget n+resultToWidget = Widget Fixed Fixed . return++threadInterface :: (HasCallStack) => TeamId -> Traversal' ChatState ThreadInterface+threadInterface tId = maybeThreadInterface(tId)._Just++-- An unsafe lens to get the specified team's thread interface. Assumes+-- the interface is present; if not, this crashes. Intended for places+-- where you know the interface will be present due to other state and+-- don't want to deal with Maybe.+unsafeThreadInterface :: (HasCallStack) => TeamId -> Lens' ChatState ThreadInterface+unsafeThreadInterface tId = maybeThreadInterface(tId).singular _Just++-- A safe version of unsafeThreadInterface.+maybeThreadInterface :: TeamId -> Lens' ChatState (Maybe ThreadInterface)+maybeThreadInterface tId = csTeam(tId).tsThreadInterface++threadInterfaceEmpty :: TeamId -> MH Bool+threadInterfaceEmpty tId = do+ mLen <- preuse (maybeThreadInterface(tId)._Just.miMessages.to messagesLength)+ case mLen of+ Nothing -> return True+ Just len -> return $ len == 0++withThreadInterface :: TeamId -> ChannelId -> MH () -> MH ()+withThreadInterface tId cId act = do+ mCid <- preuse (maybeThreadInterface(tId)._Just.miChannelId)+ case mCid of+ Just i | i == cId -> act+ _ -> return ()++threadInterfaceDeleteWhere :: TeamId -> ChannelId -> (Message -> Bool) -> MH ()+threadInterfaceDeleteWhere tId cId f =+ withThreadInterface tId cId $ do+ maybeThreadInterface(tId)._Just.miMessages.traversed.filtered f %=+ (& mDeleted .~ True)++modifyThreadMessages :: TeamId -> ChannelId -> (Messages -> Messages) -> MH ()+modifyThreadMessages tId cId f = do+ withThreadInterface tId cId $ do+ maybeThreadInterface(tId)._Just.miMessages %= f++modifyEachThreadMessage :: TeamId -> ChannelId -> (Message -> Message) -> MH ()+modifyEachThreadMessage tId cId f = do+ withThreadInterface tId cId $ do+ maybeThreadInterface(tId)._Just.miMessages.traversed %= f
src/Matterhorn/Types/Channels.hs view
@@ -8,25 +8,17 @@ module Matterhorn.Types.Channels ( ClientChannel(..)- , ChannelContents(..) , ChannelInfo(..) , ClientChannels -- constructor remains internal+ , chanMap , NewMessageIndicator(..)- , EphemeralEditState(..)- , EditMode(..)- , eesMultiline, eesInputHistoryPosition, eesLastInput- , defaultEphemeralEditState -- * Lenses created for accessing ClientChannel fields- , ccContents, ccInfo, ccEditState+ , ccInfo, ccMessageInterface -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated , cdName, cdDisplayName, cdHeader, cdPurpose, cdType- , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId- , cdSidebarShowOverride, cdNotifyProps, cdTeamId- -- * Lenses created for accessing ChannelContents fields- , cdMessages, cdFetchPending- -- * Creating ClientChannel objects- , makeClientChannel+ , cdMentionCount, cdDMUserId, cdChannelId+ , cdSidebarShowOverride, cdNotifyProps, cdTeamId, cdFetchPending -- * Managing ClientChannel collections , noChannels, addChannel, removeChannel, findChannelById, modifyChannelById , channelByIdL, maybeChannelByIdL@@ -41,7 +33,6 @@ , adjustUpdated , adjustEditedThreshold , updateNewMessageIndicator- , addChannelTypingUser -- * Notification settings , notifyPreference , isMuted@@ -57,6 +48,7 @@ , getDmChannelFor , allDmChannelMappings , getChannelNameSet+ , emptyChannelMessages ) where @@ -65,7 +57,6 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Set as S-import qualified Data.Text as T import Lens.Micro.Platform ( (%~), (.~), Traversal', Lens' , makeLenses, ix, at , to, non )@@ -81,14 +72,14 @@ , WithDefault(..) , ServerTime , TeamId- , emptyChannelNotifyProps ) import Matterhorn.Types.Messages ( Messages, noMessages, addMessage- , clientMessageToMessage, Message, MessageType )+ , clientMessageToMessage ) import Matterhorn.Types.Posts ( ClientMessageType(UnknownGapBefore) , newClientMessage )-import Matterhorn.Types.Users ( TypingUsers, noTypingUsers, addTypingUser )+import Matterhorn.Types.MessageInterface+import Matterhorn.Types.Core ( Name ) import Matterhorn.Types.Common @@ -97,38 +88,12 @@ -- | A 'ClientChannel' contains both the message -- listing and the metadata about a channel data ClientChannel = ClientChannel- { _ccContents :: ChannelContents- -- ^ A list of 'Message's in the channel- , _ccInfo :: ChannelInfo+ { _ccInfo :: ChannelInfo -- ^ The 'ChannelInfo' for the channel- , _ccEditState :: EphemeralEditState- -- ^ Editor state that we swap in and out as the current channel is- -- changed.+ , _ccMessageInterface :: MessageInterface Name ()+ -- ^ The channel's message interface } --- | The input state associated with the message editor.-data EditMode =- NewPost- -- ^ The input is for a new post.- | Editing Post MessageType- -- ^ The input is ultimately to replace the body of an existing post- -- of the specified type.- | Replying Message Post- -- ^ The input is to be used as a new post in reply to the specified- -- post.- deriving (Show)--data EphemeralEditState =- EphemeralEditState { _eesMultiline :: Bool- -- ^ Whether the editor is in multiline mode- , _eesInputHistoryPosition :: Maybe Int- -- ^ The input history position, if any- , _eesLastInput :: (T.Text, EditMode)- -- ^ The input entered into the text editor last- -- time the user was focused on the channel- -- associated with this state.- }- -- Get a channel's name, depending on its type preferredChannelName :: Channel -> Text preferredChannelName ch@@ -141,30 +106,6 @@ | NewPostsStartingAt ServerTime deriving (Eq, Show) -initialChannelInfo :: UserId -> Channel -> ChannelInfo-initialChannelInfo myId chan =- let updated = chan ^. channelLastPostAtL- in ChannelInfo { _cdChannelId = chan^.channelIdL- , _cdTeamId = chan^.channelTeamIdL- , _cdViewed = Nothing- , _cdNewMessageIndicator = Hide- , _cdEditedMessageThreshold = Nothing- , _cdMentionCount = 0- , _cdUpdated = updated- , _cdName = preferredChannelName chan- , _cdDisplayName = sanitizeUserText $ channelDisplayName chan- , _cdHeader = sanitizeUserText $ chan^.channelHeaderL- , _cdPurpose = sanitizeUserText $ chan^.channelPurposeL- , _cdType = chan^.channelTypeL- , _cdNotifyProps = emptyChannelNotifyProps- , _cdTypingUsers = noTypingUsers- , _cdDMUserId = if chan^.channelTypeL == Direct- then userIdForDMChannel myId $- sanitizeUserText $ channelName chan- else Nothing- , _cdSidebarShowOverride = Nothing- }- channelInfoFromChannelWithData :: Channel -> ChannelMember -> ChannelInfo -> ChannelInfo channelInfoFromChannelWithData chan chanMember ci = let viewed = chanMember ^. to channelMemberLastViewedAt@@ -183,25 +124,15 @@ , _cdNotifyProps = chanMember^.to channelMemberNotifyProps } --- | The 'ChannelContents' is a wrapper for a list of--- 'Message' values-data ChannelContents = ChannelContents- { _cdMessages :: Messages- , _cdFetchPending :: Bool- }---- | An initial empty 'ChannelContents' value. This also contains an--- UnknownGapBefore, which is a signal that causes actual content fetching.--- The initial Gap's timestamp is the local client time, but+-- | An initial empty channel message list. This also contains an+-- UnknownGapBefore, which is a signal that causes actual content+-- fetching. The initial Gap's timestamp is the local client time, but -- subsequent fetches will synchronize with the server (and eventually -- eliminate this Gap as well).-emptyChannelContents :: MonadIO m => m ChannelContents-emptyChannelContents = do+emptyChannelMessages :: MonadIO m => m Messages+emptyChannelMessages = do gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGapBefore "--Fetching messages--"- return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages- , _cdFetchPending = False- }-+ return $ addMessage gapMsg noMessages ------------------------------------------------------------------------ @@ -234,8 +165,6 @@ -- ^ The type of a channel: public, private, or DM , _cdNotifyProps :: ChannelNotifyProps -- ^ The user's notification settings for this channel- , _cdTypingUsers :: TypingUsers- -- ^ The users who are currently typing in this channel , _cdDMUserId :: Maybe UserId -- ^ The user associated with this channel, if it is a DM channel , _cdSidebarShowOverride :: Maybe UTCTime@@ -243,14 +172,14 @@ -- considerations as long as the specified timestamp meets a cutoff. -- Otherwise fall back to other application policy to determine -- whether to show the channel.+ , _cdFetchPending :: Bool+ -- ^ Whether a fetch in this channel is pending } -- ** Channel-related Lenses -makeLenses ''ChannelContents makeLenses ''ChannelInfo makeLenses ''ClientChannel-makeLenses ''EphemeralEditState isMuted :: ClientChannel -> Bool isMuted cc = cc^.ccInfo.cdNotifyProps.channelNotifyPropsMarkUnreadL ==@@ -265,38 +194,18 @@ -- ** Miscellaneous channel operations -makeClientChannel :: (MonadIO m) => UserId -> Channel -> m ClientChannel-makeClientChannel myId nc = emptyChannelContents >>= \contents ->- return ClientChannel- { _ccContents = contents- , _ccInfo = initialChannelInfo myId nc- , _ccEditState = defaultEphemeralEditState- }--defaultEphemeralEditState :: EphemeralEditState-defaultEphemeralEditState =- EphemeralEditState { _eesMultiline = False- , _eesInputHistoryPosition = Nothing- , _eesLastInput = ("", NewPost)- }- canLeaveChannel :: ChannelInfo -> Bool canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct] -- ** Manage the collection of all Channels -data ChannelCollection a =- ChannelCollection { _chanMap :: HashMap ChannelId a- , _channelNameSet :: HashMap TeamId (S.Set Text)- , _userChannelMap :: HashMap UserId ChannelId- }- deriving (Functor, Foldable, Traversable)---- | Define the exported typename which universally binds the--- collection to the ChannelInfo type.-type ClientChannels = ChannelCollection ClientChannel+data ClientChannels =+ ClientChannels { _chanMap :: HashMap ChannelId ClientChannel+ , _channelNameSet :: HashMap TeamId (S.Set Text)+ , _userChannelMap :: HashMap UserId ChannelId+ } -makeLenses ''ChannelCollection+makeLenses ''ClientChannels getChannelNameSet :: TeamId -> ClientChannels -> S.Set Text getChannelNameSet tId cs = case cs^.channelNameSet.at tId of@@ -306,10 +215,10 @@ -- | Initial collection of Channels with no members noChannels :: ClientChannels noChannels =- ChannelCollection { _chanMap = HM.empty- , _channelNameSet = HM.empty- , _userChannelMap = HM.empty- }+ ClientChannels { _chanMap = HM.empty+ , _channelNameSet = HM.empty+ , _userChannelMap = HM.empty+ } -- | Add a channel to the existing collection. addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels@@ -338,12 +247,12 @@ & removeChannelName & userChannelMap %~ HM.filter (/= cId) -instance Semigroup (ChannelCollection ClientChannel) where+instance Semigroup ClientChannels where a <> b = let pairs = HM.toList $ _chanMap a in foldr (uncurry addChannel) b pairs -instance Monoid (ChannelCollection ClientChannel) where+instance Monoid ClientChannels where mempty = noChannels #if !MIN_VERSION_base(4,11,0) mappend = (<>)@@ -393,10 +302,6 @@ -- * Channel State management ---- | Add user to the list of users in this channel who are currently typing.-addChannelTypingUser :: UserId -> UTCTime -> ClientChannel -> ClientChannel-addChannelTypingUser uId ts = ccInfo.cdTypingUsers %~ (addTypingUser uId ts) -- | Clear the new message indicator for the specified channel clearNewMessageIndicator :: ClientChannel -> ClientChannel
+ src/Matterhorn/Types/Core.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+module Matterhorn.Types.Core+ ( Name(..)+ , ChannelListEntry(..)+ , ChannelListEntryType(..)+ , ChannelSelectMatch(..)+ , LinkTarget(..)++ , MessageId(..)+ , messageIdPostId++ , ChannelListGroupLabel(..)+ , channelListGroupNames++ , MessageSelectState(..)+ , HelpScreen(..)+ )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Brick+import Data.Hashable ( Hashable )+import qualified Data.Text as T+import Data.UUID ( UUID )+import GHC.Generics ( Generic )+import Network.Mattermost.Types++import Matterhorn.Types.RichText ( URL, TeamURLName )++-- | This 'Name' type is the type used in 'brick' to identify various+-- parts of the interface.+data Name =+ MessageInterfaceMessages Name+ -- ^ The rendering of messages for the specified message interface+ -- (by editor name)+ | MessageInput ChannelId+ -- ^ The message editor for the specified channel's main message+ -- interface+ | MessageInputPrompt Name+ -- ^ A wrapper name for reporting the extent of a message editor's+ -- prompt. The specified name is the name of the editor whose prompt+ -- extent is being reported.+ | ChannelListViewport TeamId+ -- ^ The name of the channel list viewport for the specified team.+ | HelpViewport+ -- ^ The name of the viewport for the help interface.+ | PostList+ -- ^ The tag for messages rendered in the post list window.+ | HelpContent HelpScreen+ -- ^ The cache key constructor for caching help screen content.+ | CompletionList Name+ -- ^ The name of the list of completion alternatives in the+ -- specified editor's autocomplete pop-up.+ | JoinChannelList TeamId+ -- ^ The name of the channel list in the "/join" window.+ | UrlList Name+ -- ^ The name of a URL listing for the specified message interface's+ -- editor name.+ | MessagePreviewViewport Name+ -- ^ The name of the message interface editor's preview area.+ | ThemeListSearchInput TeamId+ -- ^ The list of themes in the "/theme" window for the specified+ -- team.+ | UserListSearchInput TeamId+ -- ^ The editor name for the user search input in the specified+ -- team's user list window.+ | JoinChannelListSearchInput TeamId+ -- ^ The editor name for the search input in the specified team's+ -- "/join" window.+ | UserListSearchResults TeamId+ -- ^ The list name for the specified team's user list window search+ -- results.+ | ThemeListSearchResults TeamId+ -- ^ The list name for the specified team's theme list window search+ -- results.+ | ViewMessageArea TeamId+ -- ^ The viewport for the specified team's single-message view+ -- window.+ | ViewMessageReactionsArea TeamId+ -- ^ The viewport for the specified team's single-message view+ -- window's reaction tab.+ | ChannelSidebar TeamId+ -- ^ The cache key for the specified team's channel list viewport+ -- contents.+ | ChannelSelectInput TeamId+ -- ^ The editor name for the specified team's channel selection mode+ -- editor.+ | AttachmentList ChannelId+ -- ^ The name of the attachment list for the specified channel's+ -- message interface.+ | AttachmentFileBrowser ChannelId+ | ReactionEmojiList TeamId+ -- ^ The name of the list of emoji to choose from for reactions for+ -- the specified team.+ | ReactionEmojiListInput TeamId+ -- ^ The name of the search editor for the specified team's emoji+ -- search window.+ | TabbedWindowTabBar TeamId+ -- ^ The name of the specified team's tabbed window tab bar+ -- viewport.+ | MuteToggleField TeamId+ -- ^ The name of the channel preferences mute form field.+ | ChannelMentionsField TeamId+ -- ^ The name of the channel preferences mentions form field.+ | DesktopNotificationsField TeamId (WithDefault NotifyOption)+ -- ^ The name of the channel preferences desktop notifications form+ -- field.+ | PushNotificationsField TeamId (WithDefault NotifyOption)+ -- ^ The name of the channel preferences push notifications form+ -- field.+ | ChannelTopicEditor TeamId+ -- ^ The specified team's channel topic window editor.+ | ChannelTopicSaveButton TeamId+ -- ^ The specified team's channel topic window save button.+ | ChannelTopicCancelButton TeamId+ -- ^ The specified team's channel topic window canel button.+ | ChannelTopicEditorPreview TeamId+ -- ^ The specified team's channel topic window preview area+ -- viewport.+ | ThreadMessageInput ChannelId+ -- ^ The message editor for the specified channel's thread view.+ | ThreadEditorAttachmentList ChannelId+ -- ^ The list name for the specified channel's thread message+ -- interface's attachment list.+ | ChannelTopic ChannelId+ -- ^ The mouse click area tag for a rendered channel topic.+ | TeamList+ -- ^ The viewport name for the team list.+ | ClickableChannelSelectEntry ChannelSelectMatch+ -- ^ The name of a clickable channel select entry in the channel+ -- select match list.+ | ClickableChannelListEntry ChannelId+ -- ^ The name of a clickable entry in the channel list.+ | ClickableTeamListEntry TeamId+ -- ^ The name of a clickable entry in the team list.+ | ClickableURL (Maybe MessageId) Name Int LinkTarget+ -- ^ The name of a clickable URL rendered in RichText. If provided,+ -- the message ID is the ID of the message in which the URL appears.+ -- The integer is the URL index in the rich text block for unique+ -- identification.+ | ClickableReaction PostId Name Text (Set UserId)+ -- ^ The name of a clickable reaction rendered in RichText when it+ -- is part of a message.+ | ClickableAttachmentInMessage Name FileId+ -- ^ The name of a clickable attachment.+ | ClickableUsername (Maybe MessageId) Name Int Text+ -- ^ The name of a clickable username rendered in RichText. The+ -- message ID and integer sequence number uniquely identify the+ -- clickable region.+ | ClickableURLListEntry Int LinkTarget+ -- ^ The name of a clickable URL list entry. The integer is the list+ -- index.+ | ClickableChannelListGroupHeading ChannelListGroupLabel+ -- ^ The name of a clickable channel list group heading.+ | ClickableReactionEmojiListWindowEntry (Bool, T.Text)+ -- ^ The name of a clickable reaction emoji list entry.+ | AttachmentPathEditor Name+ -- ^ The name of the specified message interface's attachment+ -- browser path editor.+ | AttachmentPathSaveButton Name+ -- ^ The name of the specified message interface's attachment+ -- browser save button.+ | AttachmentPathCancelButton Name+ -- ^ The name of the specified message interface's attachment+ -- browser cancel button.+ | RenderedMessage MessageId+ -- ^ The cache key for the rendering of the specified message.+ | SelectedChannelListEntry TeamId+ -- ^ The name of the specified team's currently selected channel+ -- list entry, used to bring the entry into view in its viewport.+ | VScrollBar Brick.ClickableScrollbarElement Name+ -- ^ The name of the scroll bar elements for the specified viewport+ -- name.+ deriving (Eq, Show, Ord)++-- | A match in channel selection mode.+data ChannelSelectMatch =+ ChannelSelectMatch { nameBefore :: Text+ -- ^ The content of the match before the user's+ -- matching input.+ , nameMatched :: Text+ -- ^ The potion of the name that matched the+ -- user's input.+ , nameAfter :: Text+ -- ^ The portion of the name that came after the+ -- user's matching input.+ , matchFull :: Text+ -- ^ The full string for this entry so it doesn't+ -- have to be reassembled from the parts above.+ , matchEntry :: ChannelListEntry+ -- ^ The original entry data corresponding to the+ -- text match.+ }+ deriving (Eq, Show, Ord)++-- | The type of channel list entries.+data ChannelListEntry =+ ChannelListEntry { channelListEntryChannelId :: ChannelId+ , channelListEntryType :: ChannelListEntryType+ , channelListEntryUnread :: Bool+ , channelListEntrySortValue :: T.Text+ , channelListEntryFavorite :: Bool+ , channelListEntryMuted :: Bool+ }+ deriving (Eq, Show, Ord)++data ChannelListEntryType =+ CLChannel+ -- ^ A non-DM entry+ | CLUserDM UserId+ -- ^ A single-user DM entry+ | CLGroupDM+ -- ^ A multi-user DM entry+ deriving (Eq, Show, Ord)++-- | The 'HelpScreen' type represents the set of possible 'Help' screens+-- we have to choose from.+data HelpScreen =+ MainHelp+ | ScriptHelp+ | ThemeHelp+ | SyntaxHighlightHelp+ | KeybindingHelp+ deriving (Eq, Show, Ord)++data LinkTarget =+ LinkURL URL+ | LinkFileId FileId+ | LinkPermalink TeamURLName PostId+ deriving (Eq, Show, Ord)++data MessageId = MessagePostId PostId+ | MessageUUID UUID+ deriving (Eq, Read, Ord, Show, Generic, Hashable)++messageIdPostId :: MessageId -> Maybe PostId+messageIdPostId (MessagePostId p) = Just p+messageIdPostId _ = Nothing++data ChannelListGroupLabel =+ ChannelGroupPublicChannels+ | ChannelGroupPrivateChannels+ | ChannelGroupFavoriteChannels+ | ChannelGroupDirectMessages+ deriving (Eq, Ord, Show)++channelListGroupNames :: [(T.Text, ChannelListGroupLabel)]+channelListGroupNames =+ [ ("public", ChannelGroupPublicChannels)+ , ("private", ChannelGroupPrivateChannels)+ , ("favorite", ChannelGroupFavoriteChannels)+ , ("direct", ChannelGroupDirectMessages)+ ]++-- | The state of message selection mode.+data MessageSelectState =+ MessageSelectState { selectMessageId :: Maybe MessageId+ }
src/Matterhorn/Types/DirectionalSeq.hs view
@@ -31,6 +31,12 @@ DSeq { dseq :: Seq a } deriving (Show, Functor, Foldable, Traversable) +instance Semigroup (DirectionalSeq dir a) where+ (DSeq a) <> (DSeq b) = DSeq (a <> b)++instance Monoid (DirectionalSeq dir a) where+ mempty = DSeq mempty+ emptyDirSeq :: DirectionalSeq dir a emptyDirSeq = DSeq mempty
+ src/Matterhorn/Types/EditState.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE TemplateHaskell #-}+module Matterhorn.Types.EditState+ ( EditMode(..)+ , AttachmentData(..)+ , AutocompletionType(..)++ , CompletionSource(..)+ , SpecialMention(..)+ , specialMentionName+ , isSpecialMention++ , EditState(..)+ , newEditState+ , unsafeEsFileBrowser+ , esAttachmentList+ , esFileBrowser+ , esMisspellings+ , esEditMode+ , esEphemeral+ , esEditor+ , esAutocomplete+ , esAutocompletePending+ , esResetEditMode+ , esJustCompleted+ , esShowReplyPrompt+ , esSpellCheckTimerReset+ , esTeamId+ , esChannelId++ , EphemeralEditState(..)+ , defaultEphemeralEditState+ , eesMultiline+ , eesInputHistoryPosition+ , eesLastInput+ , eesTypingUsers+ , addEphemeralStateTypingUser++ , AutocompleteState(..)+ , acPreviousSearchString+ , acCompletionList+ , acCachedResponses+ , acType++ , AutocompleteAlternative(..)+ , autocompleteAlternativeReplacement+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick.Widgets.Edit ( Editor, editor )+import Brick.Widgets.List ( List, list )+import qualified Brick.Widgets.FileBrowser as FB+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Lens.Micro.Platform ( Lens', makeLenses, (.~), (^?!), lens, _Just+ , (%~) )+import Network.Mattermost.Types++import Matterhorn.Types.Common+import Matterhorn.Types.Messages ( Message, MessageType )+import Matterhorn.Types.Users ( TypingUsers, noTypingUsers, addTypingUser+ , addUserSigil, trimUserSigil )+import Matterhorn.Constants+++-- | A "special" mention that does not map to a specific user, but is an+-- alias that the server uses to notify users.+data SpecialMention =+ MentionAll+ -- ^ @all: notify everyone in the channel.+ | MentionChannel+ -- ^ @channel: notify everyone in the channel.++data AutocompleteAlternative =+ UserCompletion User Bool+ -- ^ User, plus whether the user is in the channel that triggered+ -- the autocomplete+ | SpecialMention SpecialMention+ -- ^ A special mention.+ | ChannelCompletion Bool Channel+ -- ^ Channel, plus whether the user is a member of the channel+ | SyntaxCompletion Text+ -- ^ Name of a skylighting syntax definition+ | CommandCompletion CompletionSource Text Text Text+ -- ^ Source, name of a slash command, argspec, and description+ | EmojiCompletion Text+ -- ^ The text of an emoji completion++-- | The source of an autocompletion alternative.+data CompletionSource = Server | Client+ deriving (Eq, Show)++specialMentionName :: SpecialMention -> Text+specialMentionName MentionChannel = "channel"+specialMentionName MentionAll = "all"++isSpecialMention :: T.Text -> Bool+isSpecialMention n = isJust $ lookup (T.toLower $ trimUserSigil n) pairs+ where+ pairs = mkPair <$> mentions+ mentions = [ MentionChannel+ , MentionAll+ ]+ mkPair v = (specialMentionName v, v)++autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text+autocompleteAlternativeReplacement (EmojiCompletion e) =+ ":" <> e <> ":"+autocompleteAlternativeReplacement (SpecialMention m) =+ addUserSigil $ specialMentionName m+autocompleteAlternativeReplacement (UserCompletion u _) =+ addUserSigil $ userUsername u+autocompleteAlternativeReplacement (ChannelCompletion _ c) =+ normalChannelSigil <> (sanitizeUserText $ channelName c)+autocompleteAlternativeReplacement (SyntaxCompletion t) =+ "```" <> t+autocompleteAlternativeReplacement (CommandCompletion _ t _ _) =+ "/" <> t++-- | The type of data that the autocompletion logic supports. We use+-- this to track the kind of completion underway in case the type of+-- completion needs to change.+data AutocompletionType =+ ACUsers+ | ACChannels+ | ACCodeBlockLanguage+ | ACEmoji+ | ACCommands+ deriving (Eq, Show)++-- | An attachment.+data AttachmentData =+ AttachmentData { attachmentDataFileInfo :: FB.FileInfo+ , attachmentDataBytes :: BS.ByteString+ }+ deriving (Eq, Show)++-- | The input state associated with the message editor.+data EditMode =+ NewPost+ -- ^ The input is for a new post.+ | Editing Post MessageType+ -- ^ The input is ultimately to replace the body of an existing post+ -- of the specified type.+ | Replying Message Post+ -- ^ The input is to be used as a new post in reply to the specified+ -- post.+ deriving (Show, Eq)++data AutocompleteState n =+ AutocompleteState { _acPreviousSearchString :: Text+ -- ^ The search string used for the+ -- currently-displayed autocomplete results, for+ -- use in deciding whether to issue another server+ -- query+ , _acCompletionList :: List n AutocompleteAlternative+ -- ^ The list of alternatives that the user+ -- selects from+ , _acType :: AutocompletionType+ -- ^ The type of data that we're completing+ , _acCachedResponses :: HM.HashMap Text [AutocompleteAlternative]+ -- ^ A cache of alternative lists, keyed on search+ -- string, for use in avoiding server requests.+ -- The idea here is that users type quickly enough+ -- (and edit their input) that would normally lead+ -- to rapid consecutive requests, some for the+ -- same strings during editing, that we can avoid+ -- that by caching them here. Note that this cache+ -- gets destroyed whenever autocompletion is not+ -- on, so this cache does not live very long.+ }++-- | The 'EditState' value contains the editor widget itself as well as+-- history and metadata we need for editing-related operations.+data EditState n =+ EditState { _esEditor :: Editor Text n+ , _esEditMode :: EditMode+ , _esEphemeral :: EphemeralEditState+ , _esMisspellings :: Set Text+ , _esAutocomplete :: Maybe (AutocompleteState n)+ -- ^ The autocomplete state. The autocompletion UI is+ -- showing only when this state is present.+ , _esResetEditMode :: EditMode+ -- ^ The editing mode to reset to after input is handled.+ , _esAutocompletePending :: Maybe Text+ -- ^ The search string associated with the latest+ -- in-flight autocompletion request. This is used to+ -- determine whether any (potentially late-arriving) API+ -- responses are for stale queries since the user can type+ -- more quickly than the server can get us the results,+ -- and we wouldn't want to show results associated with+ -- old editor states.+ , _esAttachmentList :: List n AttachmentData+ -- ^ The list of attachments to be uploaded with the post+ -- being edited.+ , _esFileBrowser :: Maybe (FB.FileBrowser n)+ -- ^ The browser for selecting attachment files. This is+ -- a Maybe because the instantiation of the FileBrowser+ -- causes it to read and ingest the target directory, so+ -- this action is deferred until the browser is needed.+ , _esJustCompleted :: Bool+ -- A flag that indicates whether the most recent editing+ -- event was a tab-completion. This is used by the smart+ -- trailing space handling.+ , _esShowReplyPrompt :: Bool+ -- ^ Whether to show the reply prompt when replying+ , _esSpellCheckTimerReset :: Maybe (IO ())+ -- ^ An action to reset the spell check timer for this+ -- editor, if a spell checker is running.+ , _esChannelId :: ChannelId+ -- ^ Channel ID associated with this edit state+ , _esTeamId :: Maybe TeamId+ -- ^ Team ID associated with this edit state (optional+ -- since not all channels are associated with teams)+ }++newEditState :: n -> n -> Maybe TeamId -> ChannelId -> EditMode -> Bool -> Maybe (IO ()) -> EditState n+newEditState editorName attachmentListName tId cId initialEditMode showReplyPrompt reset =+ EditState { _esEditor = editor editorName Nothing ""+ , _esEphemeral = defaultEphemeralEditState+ , _esEditMode = initialEditMode+ , _esResetEditMode = initialEditMode+ , _esMisspellings = mempty+ , _esAutocomplete = Nothing+ , _esAutocompletePending = Nothing+ , _esAttachmentList = list attachmentListName mempty 1+ , _esFileBrowser = Nothing+ , _esJustCompleted = False+ , _esShowReplyPrompt = showReplyPrompt+ , _esSpellCheckTimerReset = reset+ , _esChannelId = cId+ , _esTeamId = tId+ }++data EphemeralEditState =+ EphemeralEditState { _eesMultiline :: Bool+ -- ^ Whether the editor is in multiline mode+ , _eesInputHistoryPosition :: Maybe Int+ -- ^ The input history position, if any+ , _eesLastInput :: (T.Text, EditMode)+ -- ^ The input entered into the text editor last+ -- time the user was focused on the channel+ -- associated with this state.+ , _eesTypingUsers :: TypingUsers+ }++defaultEphemeralEditState :: EphemeralEditState+defaultEphemeralEditState =+ EphemeralEditState { _eesMultiline = False+ , _eesInputHistoryPosition = Nothing+ , _eesLastInput = ("", NewPost)+ , _eesTypingUsers = noTypingUsers+ }++makeLenses ''EphemeralEditState++-- | Add user to the list of users in this state who are currently typing.+addEphemeralStateTypingUser :: UserId -> UTCTime -> EphemeralEditState -> EphemeralEditState+addEphemeralStateTypingUser uId ts = eesTypingUsers %~ (addTypingUser uId ts)++makeLenses ''EditState+makeLenses ''AutocompleteState++unsafeEsFileBrowser :: Lens' (EditState n) (FB.FileBrowser n)+unsafeEsFileBrowser =+ lens (\st -> st^.esFileBrowser ^?! _Just)+ (\st t -> st & esFileBrowser .~ Just t)
src/Matterhorn/Types/KeyEvents.hs view
@@ -55,6 +55,7 @@ | ToggleChannelListVisibleEvent | ToggleExpandedChannelTopicsEvent | ShowAttachmentListEvent+ | ChangeMessageEditorFocus | EditorKillToBolEvent | EditorKillToEolEvent@@ -117,6 +118,7 @@ | FillGapEvent | CopyPostLinkEvent | FlagMessageEvent+ | OpenThreadEvent | PinMessageEvent | YankMessageEvent | YankWholeMessageEvent@@ -181,6 +183,8 @@ , ShowAttachmentListEvent + , ChangeMessageEditorFocus+ , EditorKillToBolEvent , EditorKillToEolEvent , EditorBolEvent@@ -236,6 +240,7 @@ , MoveCurrentTeamLeftEvent , MoveCurrentTeamRightEvent + , OpenThreadEvent , FlagMessageEvent , PinMessageEvent , ViewMessageEvent@@ -427,6 +432,8 @@ ShowAttachmentListEvent -> "show-attachment-list" + ChangeMessageEditorFocus -> "change-message-editor-focus"+ EditorKillToBolEvent -> "editor-kill-to-beginning-of-line" EditorKillToEolEvent -> "editor-kill-to-end-of-line" EditorBolEvent -> "editor-beginning-of-line"@@ -484,6 +491,7 @@ ActivateListItemEvent -> "activate-list-item" + OpenThreadEvent -> "open-thread" FlagMessageEvent -> "flag-message" PinMessageEvent -> "pin-message" ViewMessageEvent -> "view-message"
+ src/Matterhorn/Types/MessageInterface.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell #-}+module Matterhorn.Types.MessageInterface+ ( MessageInterface(..)+ , miMessages+ , miEditor+ , miMode+ , miMessageSelect+ , miRootPostId+ , miChannelId+ , miTarget+ , miUrlListSource+ , miUrlList+ , miSaveAttachmentDialog++ , messageInterfaceCursor++ , MessageInterfaceMode(..)+ , MessageInterfaceTarget(..)+ , URLListSource(..)++ , URLList(..)+ , ulList+ , ulSource++ , SaveAttachmentDialogState(..)+ , attachmentPathEditor+ , attachmentPathDialogFocus+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick ( getName )+import Brick.Focus ( FocusRing )+import Brick.Widgets.List ( List )+import Brick.Widgets.Edit ( Editor )+import Brick.Widgets.FileBrowser ( fileBrowserNameG )+import qualified Data.Text as T+import Lens.Micro.Platform ( makeLenses, _Just )+import Network.Mattermost.Types ( ChannelId, TeamId )++import Matterhorn.Types.Core ( MessageSelectState )+import Matterhorn.Types.EditState+import Matterhorn.Types.Messages+++-- | A UI region in which a specific message listing is viewed, where+-- the user can send messages in that channel or thread.+data MessageInterface n i =+ MessageInterface { _miMessages :: Messages+ -- ^ The messages.+ , _miEditor :: EditState n+ -- ^ The editor and associated state for composing+ -- messages in this channel or thread.+ , _miMessageSelect :: MessageSelectState+ -- ^ Message selection state for the interface.+ , _miRootPostId :: i+ -- ^ The root post ID if these messages belong to a+ -- thread.+ , _miChannelId :: ChannelId+ -- ^ The channel that these messages belong to.+ , _miMode :: MessageInterfaceMode+ -- ^ The mode of the interface.+ , _miTarget :: MessageInterfaceTarget+ -- ^ The target value for this message interface+ , _miUrlListSource :: URLListSource+ -- ^ How to characterize the URLs found in messages+ -- in this interface+ , _miUrlList :: URLList n+ -- ^ The URL listing for this interface+ , _miSaveAttachmentDialog :: SaveAttachmentDialogState n+ -- ^ The state for the interactive attachment-saving+ -- editor window.+ }++messageInterfaceCursor :: MessageInterface n i -> Maybe n+messageInterfaceCursor mi =+ case _miMode mi of+ Compose -> Just $ getName $ _esEditor $ _miEditor mi+ SaveAttachment {} -> Just $ getName $ _attachmentPathEditor $ _miSaveAttachmentDialog mi+ BrowseFiles -> (_esFileBrowser $ _miEditor mi)^?_Just.fileBrowserNameG+ ManageAttachments -> Nothing+ MessageSelect -> Nothing+ ShowUrlList -> Nothing++data MessageInterfaceMode =+ Compose+ -- ^ Composing messages and interacting with the editor+ | MessageSelect+ -- ^ Selecting from messages in the listing+ | ShowUrlList+ -- ^ Show the URL listing+ | SaveAttachment LinkChoice+ -- ^ Show the attachment save UI+ | ManageAttachments+ -- ^ Managing the attachment list+ | BrowseFiles+ -- ^ Browsing the filesystem for attachment files+ deriving (Eq, Show)++data URLListSource =+ FromChannel ChannelId+ | FromThreadIn ChannelId+ deriving (Show, Eq)++data MessageInterfaceTarget =+ MITeamThread TeamId+ | MIChannel ChannelId+ deriving (Eq, Show)++data URLList n =+ URLList { _ulList :: List n (Int, LinkChoice)+ , _ulSource :: Maybe URLListSource+ }++-- | The state of the attachment path window.+data SaveAttachmentDialogState n =+ SaveAttachmentDialogState { _attachmentPathEditor :: Editor T.Text n+ -- ^ The attachment path editor state.+ , _attachmentPathDialogFocus :: FocusRing n+ -- ^ The window focus state (editor/buttons)+ }++makeLenses ''MessageInterface+makeLenses ''URLList+makeLenses ''SaveAttachmentDialogState
src/Matterhorn/Types/Messages.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}@@ -48,12 +46,10 @@ , mOriginalPost, mChannelId, mMarkdownSource , isBotMessage , MessageType(..)- , MessageId(..) , ThreadState(..) , MentionedUser(..) , isPostMessage , messagePostId- , messageIdPostId , UserRef(..) , ReplyState(..) , clientMessageToMessage@@ -95,7 +91,6 @@ , withFirstMessage , msgURLs - , LinkTarget(..) , LinkChoice(LinkChoice, _linkTarget) , linkUser , linkTarget@@ -109,20 +104,18 @@ import Control.Monad import qualified Data.Foldable as F-import Data.Hashable ( Hashable ) import qualified Data.Map.Strict as Map import Data.Sequence as Seq import qualified Data.Set as S import Data.Tuple-import Data.UUID ( UUID )-import GHC.Generics ( Generic ) import Lens.Micro.Platform ( makeLenses ) import Network.Mattermost.Types ( ChannelId, PostId, Post- , ServerTime, UserId, FileId+ , ServerTime, UserId ) import Matterhorn.Types.DirectionalSeq+import Matterhorn.Types.Core import Matterhorn.Types.Posts import Matterhorn.Types.RichText @@ -142,14 +135,6 @@ -- ---------------------------------------------------------------------- -- * Messages -data MessageId = MessagePostId PostId- | MessageUUID UUID- deriving (Eq, Read, Ord, Show, Generic, Hashable)--messageIdPostId :: MessageId -> Maybe PostId-messageIdPostId (MessagePostId p) = Just p-messageIdPostId _ = Nothing- -- | A 'Message' is any message we might want to render, either from -- Mattermost itself or from a client-internal source. data Message = Message@@ -168,7 +153,7 @@ , _mFlagged :: Bool , _mPinned :: Bool , _mChannelId :: Maybe ChannelId- } deriving (Show)+ } deriving (Show, Eq) isPostMessage :: Message -> Bool isPostMessage m =@@ -257,7 +242,7 @@ -- the union of both kinds of post types. data MessageType = C ClientMessageType | CP ClientPostType- deriving (Show)+ deriving (Show, Eq) -- | There may be no user (usually an internal message), a reference to -- a user (by Id), or the server may have supplied a specific username@@ -279,12 +264,6 @@ NotAReply | InReplyTo PostId deriving (Show, Eq)--data LinkTarget =- LinkURL URL- | LinkFileId FileId- | LinkPermalink TeamURLName PostId- deriving (Eq, Show, Ord) -- | This type represents links to things in the 'open links' view. data LinkChoice =
+ src/Matterhorn/Types/NonemptyStack.hs view
@@ -0,0 +1,51 @@+module Matterhorn.Types.NonemptyStack+ ( NonemptyStack+ , newStack+ , push+ , pop+ , top+ , stackToList+ )+where++import Prelude ()+import Matterhorn.Prelude++-- | A stack that always has at least one value on it.+data NonemptyStack a =+ NonemptyStack { bottom :: !a+ -- ^ The value at the bottom that can never be+ -- removed.+ , rest :: ![a]+ -- ^ The rest of the stack, topmost element first.+ }+ deriving (Show)++-- | Make a new stack with the specified value at the bottom.+newStack :: a -> NonemptyStack a+newStack v = NonemptyStack { bottom = v+ , rest = []+ }+++-- | Return the stack as a list, topmost element first.+stackToList :: NonemptyStack a -> [a]+stackToList (NonemptyStack b as) = as <> [b]++-- | Pop the top value from the stack. If a value could be popped,+-- return the new stack and the value that was popped. Otherwise return+-- the stack unmodified with @Nothing@ to indicate that nothing was+-- popped.+pop :: NonemptyStack a -> (NonemptyStack a, Maybe a)+pop s@(NonemptyStack _ []) = (s, Nothing)+pop s@(NonemptyStack _ (a:as)) = (s { rest = as }, Just a)++-- | Push the specified value on to the stack.+push :: a -> NonemptyStack a -> NonemptyStack a+push v s = s { rest = v : rest s }++-- | Return the value on the top of the stack. Always succeeds since the+-- stack is guaranteed to be non-empty.+top :: NonemptyStack a -> a+top (NonemptyStack _ (a:_)) = a+top (NonemptyStack bot []) = bot
src/Matterhorn/Types/Posts.hs view
@@ -100,7 +100,7 @@ | UnknownGapAfter -- ^ a region where server may have messages -- after the given timestamp that are not known -- locally by this client- deriving (Show)+ deriving (Show, Eq) -- ** 'ClientMessage' Lenses
src/Matterhorn/Types/RichText.hs view
@@ -71,7 +71,7 @@ -- | A sequence of rich text blocks. newtype Blocks = Blocks (Seq Block)- deriving (Semigroup, Monoid, Show)+ deriving (Semigroup, Monoid, Show, Eq) unBlocks :: Blocks -> Seq Block unBlocks (Blocks bs) = bs@@ -100,7 +100,7 @@ -- ^ A horizontal rule. | Table [C.ColAlignment] [Inlines] [[Inlines]] -- ^ A table.- deriving (Show)+ deriving (Show, Eq) -- | Returns whether two blocks have the same type. sameBlockType :: Block -> Block -> Bool@@ -270,7 +270,12 @@ period = case C.tokenize "" "." of [p] -> p _ -> error "BUG: parseUsername: failed to tokenize basic input"- uts <- intersperse period <$> P.sepBy1 chunk (C.symbol '.')+ uts <- intersperse period <$> do+ c <- chunk+ rest <- P.many $ P.try $ do+ void $ C.symbol '.'+ chunk+ return $ c : rest return $ singleI $ EUser $ C.untokenize uts -- Syntax extension for parsing :emoji: references.
+ src/Matterhorn/Types/TabbedWindow.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.Types.TabbedWindow+ ( TabbedWindow(..)+ , TabbedWindowEntry(..)+ , TabbedWindowTemplate(..)++ , tabbedWindow+ , getCurrentTabbedWindowEntry+ , tabbedWindowNextTab+ , tabbedWindowPreviousTab+ , runTabShowHandlerFor+ )+where++import Prelude ()+import Matterhorn.Prelude++import Brick ( Widget )+import Data.List ( nub, elemIndex )+import qualified Data.Text as T+import qualified Graphics.Vty as Vty+++-- | An entry in a tabbed window corresponding to a tab and its content.+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindowEntry s m n a =+ TabbedWindowEntry { tweValue :: a+ -- ^ The handle for this tab.+ , tweRender :: a -> s -> Widget n+ -- ^ The rendering function to use when this tab+ -- is selected.+ , tweHandleEvent :: a -> Vty.Event -> m ()+ -- ^ The event-handling function to use when this+ -- tab is selected.+ , tweTitle :: a -> Bool -> T.Text+ -- ^ Title function for this tab, with a boolean+ -- indicating whether this is the current tab.+ , tweShowHandler :: a -> m ()+ -- ^ A handler to be invoked when this tab is+ -- shown.+ }++-- | The definition of a tabbed window. Note that this does not track+-- the *state* of the window; it merely provides a collection of tab+-- window entries (see above). To track the state of a tabbed window,+-- use a TabbedWindow.+--+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindowTemplate s m n a =+ TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry s m n a]+ -- ^ The entries in tabbed windows with this+ -- structure.+ , twtTitle :: a -> Widget n+ -- ^ The title-rendering function for this kind+ -- of tabbed window.+ }++-- | An instantiated tab window. This is based on a template and tracks+-- the state of the tabbed window (current tab).+--+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindow s m n a =+ TabbedWindow { twValue :: a+ -- ^ The handle of the currently-selected tab.+ , twTemplate :: TabbedWindowTemplate s m n a+ -- ^ The template to use as a basis for rendering the+ -- window and handling user input.+ , twWindowWidth :: Int+ , twWindowHeight :: Int+ -- ^ Window dimensions+ }++-- | Construct a new tabbed window from a template. This will raise an+-- exception if the initially-selected tab does not exist in the window+-- template, or if the window template has any duplicated tab handles.+--+-- Note that the caller is responsible for determining whether to call+-- the initially-selected tab's on-show handler.+tabbedWindow :: (Show a, Eq a)+ => a+ -- ^ The handle corresponding to the tab that should be+ -- selected initially.+ -> TabbedWindowTemplate s m n a+ -- ^ The template for the window to construct.+ -> (Int, Int)+ -- ^ The window dimensions (width, height).+ -> TabbedWindow s m n a+tabbedWindow initialVal t (width, height) =+ let handles = tweValue <$> twtEntries t+ in if | null handles ->+ error "BUG: tabbed window template must provide at least one entry"+ | length handles /= length (nub handles) ->+ error "BUG: tabbed window should have one entry per handle"+ | not (initialVal `elem` handles) ->+ error $ "BUG: tabbed window handle " <>+ show initialVal <> " not present in template"+ | otherwise ->+ TabbedWindow { twTemplate = t+ , twValue = initialVal+ , twWindowWidth = width+ , twWindowHeight = height+ }++-- | Get the currently-selected tab entry for a tabbed window. Raise+-- an exception if the window's selected tab handle is not found in its+-- template (which is a bug in the tabbed window infrastructure).+getCurrentTabbedWindowEntry :: (Show a, Eq a)+ => TabbedWindow s m n a+ -> TabbedWindowEntry s m n a+getCurrentTabbedWindowEntry w =+ lookupTabbedWindowEntry (twValue w) w++-- | Run the on-show handler for the window tab entry with the specified+-- handle.+runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow s m n a -> m ()+runTabShowHandlerFor handle w = do+ let entry = lookupTabbedWindowEntry handle w+ tweShowHandler entry handle++-- | Look up a tabbed window entry by handle. Raises an exception if no+-- such entry exists.+lookupTabbedWindowEntry :: (Eq a, Show a)+ => a+ -> TabbedWindow s m n a+ -> TabbedWindowEntry s m n a+lookupTabbedWindowEntry handle w =+ let matchesVal e = tweValue e == handle+ in case filter matchesVal (twtEntries $ twTemplate w) of+ [e] -> e+ _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <>+ " should have matched a single entry"++-- | Switch a tabbed window's selected tab to its next tab, cycling back+-- to the first tab if the last tab is the selected tab. This also+-- invokes the on-show handler for the newly-selected tab.+--+-- Note that this does nothing if the window has only one tab.+tabbedWindowNextTab :: (Monad m, Show a, Eq a)+ => TabbedWindow s m n a+ -> m (TabbedWindow s m n a)+tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w+tabbedWindowNextTab w = do+ let curIdx = case elemIndex (tweValue curEntry) allHandles of+ Nothing ->+ error $ "BUG: tabbedWindowNextTab: could not find " <>+ "current handle in handle list"+ Just i -> i+ nextIdx = if curIdx == length allHandles - 1+ then 0+ else curIdx + 1+ newHandle = allHandles !! nextIdx+ allHandles = tweValue <$> twtEntries (twTemplate w)+ curEntry = getCurrentTabbedWindowEntry w+ newWin = w { twValue = newHandle }++ runTabShowHandlerFor newHandle newWin+ return newWin++-- | Switch a tabbed window's selected tab to its previous tab, cycling+-- to the last tab if the first tab is the selected tab. This also+-- invokes the on-show handler for the newly-selected tab.+--+-- Note that this does nothing if the window has only one tab.+tabbedWindowPreviousTab :: (Monad m, Show a, Eq a)+ => TabbedWindow s m n a+ -> m (TabbedWindow s m n a)+tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w+tabbedWindowPreviousTab w = do+ let curIdx = case elemIndex (tweValue curEntry) allHandles of+ Nothing ->+ error $ "BUG: tabbedWindowPreviousTab: could not find " <>+ "current handle in handle list"+ Just i -> i+ nextIdx = if curIdx == 0+ then length allHandles - 1+ else curIdx - 1+ newHandle = allHandles !! nextIdx+ allHandles = tweValue <$> twtEntries (twTemplate w)+ curEntry = getCurrentTabbedWindowEntry w+ newWin = w { twValue = newHandle }++ runTabShowHandlerFor newHandle newWin+ return newWin
src/Matterhorn/Windows/ViewMessage.hs view
@@ -32,7 +32,7 @@ -- | The template for "View Message" windows triggered by message -- selection mode.-viewMessageWindowTemplate :: TeamId -> TabbedWindowTemplate ViewMessageWindowTab+viewMessageWindowTemplate :: TeamId -> TabbedWindowTemplate ChatState MH Name ViewMessageWindowTab viewMessageWindowTemplate tId = TabbedWindowTemplate { twtEntries = [ messageEntry tId , reactionsEntry tId@@ -40,7 +40,7 @@ , twtTitle = const $ txt "View Message" } -messageEntry :: TeamId -> TabbedWindowEntry ViewMessageWindowTab+messageEntry :: TeamId -> TabbedWindowEntry ChatState MH Name ViewMessageWindowTab messageEntry tId = TabbedWindowEntry { tweValue = VMTabMessage , tweRender = renderTab tId@@ -49,7 +49,7 @@ , tweShowHandler = onShow tId } -reactionsEntry :: TeamId -> TabbedWindowEntry ViewMessageWindowTab+reactionsEntry :: TeamId -> TabbedWindowEntry ChatState MH Name ViewMessageWindowTab reactionsEntry tId = TabbedWindowEntry { tweValue = VMTabReactions , tweRender = renderTab tId@@ -97,17 +97,18 @@ Just mId -> do cId <- cs^.csCurrentChannelId(tId) chan <- cs^?csChannel(cId)- findMessage mId $ chan^.ccContents.cdMessages+ findMessage mId $ chan^.ccMessageInterface.miMessages handleEvent :: TeamId -> ViewMessageWindowTab -> Vty.Event -> MH () handleEvent tId VMTabMessage =- void . handleKeyboardEvent (viewMessageKeybindings tId) (const $ return ())+ void . handleKeyboardEvent (viewMessageKeybindings tId) handleEvent tId VMTabReactions =- void . handleKeyboardEvent (viewMessageReactionsKeybindings tId) (const $ return ())+ void . handleKeyboardEvent (viewMessageReactionsKeybindings tId) reactionsText :: ChatState -> TeamId -> Message -> Widget Name-reactionsText st tId m = viewport (ViewMessageReactionsArea tId) Vertical body+reactionsText st tId m = viewport vpName Vertical body where+ vpName = ViewMessageReactionsArea tId body = case null reacList of True -> txt "This message has no reactions." False -> vBox $ mkEntry <$> reacList@@ -123,7 +124,7 @@ hs = getHighlightSet st tId clickableUsernames i (EUser un) =- Just $ ClickableUsername (ViewMessageReactionsArea tId) i un+ Just $ ClickableUsername Nothing vpName i un clickableUsernames _ _ = Nothing @@ -137,7 +138,7 @@ makeName e us = do pid <- postId <$> m^.mOriginalPost- Just $ ClickableReaction pid e us+ Just $ ClickableReaction pid vpName e us makeClickableName w e us = case makeName e us of@@ -173,6 +174,8 @@ , mdMyUserId = myUserId st , mdWrapNonhighlightedCodeBlocks = False , mdTruncateVerbatimBlocks = Nothing+ , mdClickableNameTag = ViewMessageArea tId+ , mdRenderReplyIndent = False } in renderMessage md
test/Message_QCA.hs view
@@ -16,6 +16,7 @@ import Matterhorn.Types.Messages import Matterhorn.Types.Posts+import Matterhorn.Types.Core genMap :: Ord key => Gen key -> Gen value -> Gen (Map key value) genMap gk gv = let kv = (,) <$> gk <*> gv in fromList <$> listOf kv
test/test_messages.hs view
@@ -26,6 +26,7 @@ import Message_QCA import Matterhorn.Types.DirectionalSeq+import Matterhorn.Types.Core import Matterhorn.Types.Messages import Matterhorn.Types.Posts import Matterhorn.Prelude