diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/docs/commands.md b/docs/commands.md --- a/docs/commands.md +++ b/docs/commands.md @@ -45,12 +45,14 @@ | `/shortcuts` | Show keyboard shortcuts | | `/theme` | List the available themes | | `/theme ` | Set the color theme | +| `/thread-orientation ` | 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 ` | Toggle the visibility of the named sidebar group | +| `/toggle-sidebar-group ` | 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 ` | Set the current channel's topic (header) | diff --git a/docs/keybindings.md b/docs/keybindings.md --- a/docs/keybindings.md +++ b/docs/keybindings.md @@ -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 | diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/src/Matterhorn/App.hs b/src/Matterhorn/App.hs --- a/src/Matterhorn/App.hs +++ b/src/Matterhorn/App.hs @@ -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 diff --git a/src/Matterhorn/Command.hs b/src/Matterhorn/Command.hs --- a/src/Matterhorn/Command.hs +++ b/src/Matterhorn/Command.hs @@ -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 diff --git a/src/Matterhorn/Command.hs-boot b/src/Matterhorn/Command.hs-boot --- a/src/Matterhorn/Command.hs-boot +++ b/src/Matterhorn/Command.hs-boot @@ -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 ) diff --git a/src/Matterhorn/Config.hs b/src/Matterhorn/Config.hs --- a/src/Matterhorn/Config.hs +++ b/src/Matterhorn/Config.hs @@ -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 } diff --git a/src/Matterhorn/Draw.hs b/src/Matterhorn/Draw.hs --- a/src/Matterhorn/Draw.hs +++ b/src/Matterhorn/Draw.hs @@ -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 diff --git a/src/Matterhorn/Draw/Autocomplete.hs b/src/Matterhorn/Draw/Autocomplete.hs --- a/src/Matterhorn/Draw/Autocomplete.hs +++ b/src/Matterhorn/Draw/Autocomplete.hs @@ -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 diff --git a/src/Matterhorn/Draw/ChannelList.hs b/src/Matterhorn/Draw/ChannelList.hs --- a/src/Matterhorn/Draw/ChannelList.hs +++ b/src/Matterhorn/Draw/ChannelList.hs @@ -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 $ diff --git a/src/Matterhorn/Draw/ChannelListOverlay.hs b/src/Matterhorn/Draw/ChannelListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/ChannelListOverlay.hs +++ /dev/null @@ -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) diff --git a/src/Matterhorn/Draw/ChannelListWindow.hs b/src/Matterhorn/Draw/ChannelListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/ChannelListWindow.hs @@ -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) diff --git a/src/Matterhorn/Draw/ChannelSelectPrompt.hs b/src/Matterhorn/Draw/ChannelSelectPrompt.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/ChannelSelectPrompt.hs @@ -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) + diff --git a/src/Matterhorn/Draw/InputPreview.hs b/src/Matterhorn/Draw/InputPreview.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/InputPreview.hs @@ -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) diff --git a/src/Matterhorn/Draw/ListOverlay.hs b/src/Matterhorn/Draw/ListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/ListOverlay.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/Draw/ListWindow.hs b/src/Matterhorn/Draw/ListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/ListWindow.hs @@ -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 diff --git a/src/Matterhorn/Draw/Main.hs b/src/Matterhorn/Draw/Main.hs --- a/src/Matterhorn/Draw/Main.hs +++ b/src/Matterhorn/Draw/Main.hs @@ -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 diff --git a/src/Matterhorn/Draw/ManageAttachments.hs b/src/Matterhorn/Draw/ManageAttachments.hs --- a/src/Matterhorn/Draw/ManageAttachments.hs +++ b/src/Matterhorn/Draw/ManageAttachments.hs @@ -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) diff --git a/src/Matterhorn/Draw/MessageDeleteConfirm.hs b/src/Matterhorn/Draw/MessageDeleteConfirm.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/MessageDeleteConfirm.hs @@ -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 + diff --git a/src/Matterhorn/Draw/MessageInterface.hs b/src/Matterhorn/Draw/MessageInterface.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/MessageInterface.hs @@ -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 "" 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" + ] diff --git a/src/Matterhorn/Draw/Messages.hs b/src/Matterhorn/Draw/Messages.hs --- a/src/Matterhorn/Draw/Messages.hs +++ b/src/Matterhorn/Draw/Messages.hs @@ -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 diff --git a/src/Matterhorn/Draw/PostListOverlay.hs b/src/Matterhorn/Draw/PostListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/PostListOverlay.hs +++ /dev/null @@ -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 -> "" - 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] diff --git a/src/Matterhorn/Draw/PostListWindow.hs b/src/Matterhorn/Draw/PostListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/PostListWindow.hs @@ -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 -> "" + 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] diff --git a/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs b/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/ReactionEmojiListOverlay.hs +++ /dev/null @@ -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 <> ":" - ] diff --git a/src/Matterhorn/Draw/ReactionEmojiListWindow.hs b/src/Matterhorn/Draw/ReactionEmojiListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/ReactionEmojiListWindow.hs @@ -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 <> ":" + ] diff --git a/src/Matterhorn/Draw/SaveAttachmentWindow.hs b/src/Matterhorn/Draw/SaveAttachmentWindow.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/SaveAttachmentWindow.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/Draw/ShowHelp.hs b/src/Matterhorn/Draw/ShowHelp.hs --- a/src/Matterhorn/Draw/ShowHelp.hs +++ b/src/Matterhorn/Draw/ShowHelp.hs @@ -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 diff --git a/src/Matterhorn/Draw/TabbedWindow.hs b/src/Matterhorn/Draw/TabbedWindow.hs --- a/src/Matterhorn/Draw/TabbedWindow.hs +++ b/src/Matterhorn/Draw/TabbedWindow.hs @@ -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 diff --git a/src/Matterhorn/Draw/ThemeListOverlay.hs b/src/Matterhorn/Draw/ThemeListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/ThemeListOverlay.hs +++ /dev/null @@ -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 ' ') diff --git a/src/Matterhorn/Draw/ThemeListWindow.hs b/src/Matterhorn/Draw/ThemeListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/ThemeListWindow.hs @@ -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 ' ') diff --git a/src/Matterhorn/Draw/URLList.hs b/src/Matterhorn/Draw/URLList.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/URLList.hs +++ /dev/null @@ -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 "" 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 diff --git a/src/Matterhorn/Draw/UserListOverlay.hs b/src/Matterhorn/Draw/UserListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Draw/UserListOverlay.hs +++ /dev/null @@ -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 <> ">")) diff --git a/src/Matterhorn/Draw/UserListWindow.hs b/src/Matterhorn/Draw/UserListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Draw/UserListWindow.hs @@ -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 <> ">")) diff --git a/src/Matterhorn/Draw/Util.hs b/src/Matterhorn/Draw/Util.hs --- a/src/Matterhorn/Draw/Util.hs +++ b/src/Matterhorn/Draw/Util.hs @@ -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 + ] diff --git a/src/Matterhorn/Events.hs b/src/Matterhorn/Events.hs --- a/src/Matterhorn/Events.hs +++ b/src/Matterhorn/Events.hs @@ -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 diff --git a/src/Matterhorn/Events/ChannelListOverlay.hs b/src/Matterhorn/Events/ChannelListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Events/ChannelListOverlay.hs +++ /dev/null @@ -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)) - ] diff --git a/src/Matterhorn/Events/ChannelListWindow.hs b/src/Matterhorn/Events/ChannelListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/ChannelListWindow.hs @@ -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)) + ] diff --git a/src/Matterhorn/Events/ChannelSelect.hs b/src/Matterhorn/Events/ChannelSelect.hs --- a/src/Matterhorn/Events/ChannelSelect.hs +++ b/src/Matterhorn/Events/ChannelSelect.hs @@ -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 diff --git a/src/Matterhorn/Events/ChannelTopicWindow.hs b/src/Matterhorn/Events/ChannelTopicWindow.hs --- a/src/Matterhorn/Events/ChannelTopicWindow.hs +++ b/src/Matterhorn/Events/ChannelTopicWindow.hs @@ -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 diff --git a/src/Matterhorn/Events/DeleteChannelConfirm.hs b/src/Matterhorn/Events/DeleteChannelConfirm.hs --- a/src/Matterhorn/Events/DeleteChannelConfirm.hs +++ b/src/Matterhorn/Events/DeleteChannelConfirm.hs @@ -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 diff --git a/src/Matterhorn/Events/EditNotifyPrefs.hs b/src/Matterhorn/Events/EditNotifyPrefs.hs --- a/src/Matterhorn/Events/EditNotifyPrefs.hs +++ b/src/Matterhorn/Events/EditNotifyPrefs.hs @@ -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) diff --git a/src/Matterhorn/Events/Keybindings.hs b/src/Matterhorn/Events/Keybindings.hs --- a/src/Matterhorn/Events/Keybindings.hs +++ b/src/Matterhorn/Events/Keybindings.hs @@ -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 ] diff --git a/src/Matterhorn/Events/LeaveChannelConfirm.hs b/src/Matterhorn/Events/LeaveChannelConfirm.hs --- a/src/Matterhorn/Events/LeaveChannelConfirm.hs +++ b/src/Matterhorn/Events/LeaveChannelConfirm.hs @@ -17,5 +17,5 @@ Vty.KChar c | c `elem` ("yY"::String) -> leaveCurrentChannel tId _ -> return () - setMode tId Main + popMode tId onEventLeaveChannelConfirm _ _ = return () diff --git a/src/Matterhorn/Events/Main.hs b/src/Matterhorn/Events/Main.hs --- a/src/Matterhorn/Events/Main.hs +++ b/src/Matterhorn/Events/Main.hs @@ -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 diff --git a/src/Matterhorn/Events/ManageAttachments.hs b/src/Matterhorn/Events/ManageAttachments.hs --- a/src/Matterhorn/Events/ManageAttachments.hs +++ b/src/Matterhorn/Events/ManageAttachments.hs @@ -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 diff --git a/src/Matterhorn/Events/MessageInterface.hs b/src/Matterhorn/Events/MessageInterface.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/MessageInterface.hs @@ -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 + ] + diff --git a/src/Matterhorn/Events/MessageSelect.hs b/src/Matterhorn/Events/MessageSelect.hs --- a/src/Matterhorn/Events/MessageSelect.hs +++ b/src/Matterhorn/Events/MessageSelect.hs @@ -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 ] diff --git a/src/Matterhorn/Events/Mouse.hs b/src/Matterhorn/Events/Mouse.hs --- a/src/Matterhorn/Events/Mouse.hs +++ b/src/Matterhorn/Events/Mouse.hs @@ -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 () diff --git a/src/Matterhorn/Events/PostListOverlay.hs b/src/Matterhorn/Events/PostListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Events/PostListOverlay.hs +++ /dev/null @@ -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 - ] diff --git a/src/Matterhorn/Events/PostListWindow.hs b/src/Matterhorn/Events/PostListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/PostListWindow.hs @@ -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 + ] diff --git a/src/Matterhorn/Events/ReactionEmojiListOverlay.hs b/src/Matterhorn/Events/ReactionEmojiListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Events/ReactionEmojiListOverlay.hs +++ /dev/null @@ -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)) - ] diff --git a/src/Matterhorn/Events/ReactionEmojiListWindow.hs b/src/Matterhorn/Events/ReactionEmojiListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/ReactionEmojiListWindow.hs @@ -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)) + ] diff --git a/src/Matterhorn/Events/SaveAttachmentWindow.hs b/src/Matterhorn/Events/SaveAttachmentWindow.hs --- a/src/Matterhorn/Events/SaveAttachmentWindow.hs +++ b/src/Matterhorn/Events/SaveAttachmentWindow.hs @@ -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 diff --git a/src/Matterhorn/Events/ShowHelp.hs b/src/Matterhorn/Events/ShowHelp.hs --- a/src/Matterhorn/Events/ShowHelp.hs +++ b/src/Matterhorn/Events/ShowHelp.hs @@ -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 diff --git a/src/Matterhorn/Events/TabbedWindow.hs b/src/Matterhorn/Events/TabbedWindow.hs --- a/src/Matterhorn/Events/TabbedWindow.hs +++ b/src/Matterhorn/Events/TabbedWindow.hs @@ -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 diff --git a/src/Matterhorn/Events/ThemeListOverlay.hs b/src/Matterhorn/Events/ThemeListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Events/ThemeListOverlay.hs +++ /dev/null @@ -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)) - ] diff --git a/src/Matterhorn/Events/ThemeListWindow.hs b/src/Matterhorn/Events/ThemeListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/ThemeListWindow.hs @@ -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)) + ] diff --git a/src/Matterhorn/Events/ThreadWindow.hs b/src/Matterhorn/Events/ThreadWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/ThreadWindow.hs @@ -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 diff --git a/src/Matterhorn/Events/UrlSelect.hs b/src/Matterhorn/Events/UrlSelect.hs --- a/src/Matterhorn/Events/UrlSelect.hs +++ b/src/Matterhorn/Events/UrlSelect.hs @@ -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 ] diff --git a/src/Matterhorn/Events/UserListOverlay.hs b/src/Matterhorn/Events/UserListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/Events/UserListOverlay.hs +++ /dev/null @@ -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)) - ] diff --git a/src/Matterhorn/Events/UserListWindow.hs b/src/Matterhorn/Events/UserListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Events/UserListWindow.hs @@ -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)) + ] diff --git a/src/Matterhorn/Events/Websocket.hs b/src/Matterhorn/Events/Websocket.hs --- a/src/Matterhorn/Events/Websocket.hs +++ b/src/Matterhorn/Events/Websocket.hs @@ -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 diff --git a/src/Matterhorn/HelpTopics.hs b/src/Matterhorn/HelpTopics.hs --- a/src/Matterhorn/HelpTopics.hs +++ b/src/Matterhorn/HelpTopics.hs @@ -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 = diff --git a/src/Matterhorn/LastRunState.hs b/src/Matterhorn/LastRunState.hs --- a/src/Matterhorn/LastRunState.hs +++ b/src/Matterhorn/LastRunState.hs @@ -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 diff --git a/src/Matterhorn/Scripts.hs b/src/Matterhorn/Scripts.hs --- a/src/Matterhorn/Scripts.hs +++ b/src/Matterhorn/Scripts.hs @@ -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 diff --git a/src/Matterhorn/State/Async.hs b/src/Matterhorn/State/Async.hs --- a/src/Matterhorn/State/Async.hs +++ b/src/Matterhorn/State/Async.hs @@ -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. diff --git a/src/Matterhorn/State/Attachments.hs b/src/Matterhorn/State/Attachments.hs --- a/src/Matterhorn/State/Attachments.hs +++ b/src/Matterhorn/State/Attachments.hs @@ -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 diff --git a/src/Matterhorn/State/Autocomplete.hs b/src/Matterhorn/State/Autocomplete.hs --- a/src/Matterhorn/State/Autocomplete.hs +++ b/src/Matterhorn/State/Autocomplete.hs @@ -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 = diff --git a/src/Matterhorn/State/ChannelListOverlay.hs b/src/Matterhorn/State/ChannelListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/State/ChannelListOverlay.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/State/ChannelListWindow.hs b/src/Matterhorn/State/ChannelListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/ChannelListWindow.hs @@ -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 diff --git a/src/Matterhorn/State/ChannelSelect.hs b/src/Matterhorn/State/ChannelSelect.hs --- a/src/Matterhorn/State/ChannelSelect.hs +++ b/src/Matterhorn/State/ChannelSelect.hs @@ -23,7 +23,7 @@ beginChannelSelect :: MM.TeamId -> MH () beginChannelSelect tId = do - setMode tId ChannelSelect + pushMode tId ChannelSelect csTeam(tId).tsChannelSelectState .= emptyChannelSelectState tId updateChannelSelectMatches tId diff --git a/src/Matterhorn/State/ChannelTopicWindow.hs b/src/Matterhorn/State/ChannelTopicWindow.hs --- a/src/Matterhorn/State/ChannelTopicWindow.hs +++ b/src/Matterhorn/State/ChannelTopicWindow.hs @@ -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 diff --git a/src/Matterhorn/State/Channels.hs b/src/Matterhorn/State/Channels.hs --- a/src/Matterhorn/State/Channels.hs +++ b/src/Matterhorn/State/Channels.hs @@ -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 () diff --git a/src/Matterhorn/State/Common.hs b/src/Matterhorn/State/Common.hs --- a/src/Matterhorn/State/Common.hs +++ b/src/Matterhorn/State/Common.hs @@ -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." diff --git a/src/Matterhorn/State/Editing.hs b/src/Matterhorn/State/Editing.hs --- a/src/Matterhorn/State/Editing.hs +++ b/src/Matterhorn/State/Editing.hs @@ -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 diff --git a/src/Matterhorn/State/Editing.hs-boot b/src/Matterhorn/State/Editing.hs-boot --- a/src/Matterhorn/State/Editing.hs-boot +++ b/src/Matterhorn/State/Editing.hs-boot @@ -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 () diff --git a/src/Matterhorn/State/Flagging.hs b/src/Matterhorn/State/Flagging.hs --- a/src/Matterhorn/State/Flagging.hs +++ b/src/Matterhorn/State/Flagging.hs @@ -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 () diff --git a/src/Matterhorn/State/Help.hs b/src/Matterhorn/State/Help.hs --- a/src/Matterhorn/State/Help.hs +++ b/src/Matterhorn/State/Help.hs @@ -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 diff --git a/src/Matterhorn/State/Links.hs b/src/Matterhorn/State/Links.hs --- a/src/Matterhorn/State/Links.hs +++ b/src/Matterhorn/State/Links.hs @@ -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 ) diff --git a/src/Matterhorn/State/ListOverlay.hs b/src/Matterhorn/State/ListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/State/ListOverlay.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/State/ListWindow.hs b/src/Matterhorn/State/ListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/ListWindow.hs @@ -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 diff --git a/src/Matterhorn/State/MessageSelect.hs b/src/Matterhorn/State/MessageSelect.hs --- a/src/Matterhorn/State/MessageSelect.hs +++ b/src/Matterhorn/State/MessageSelect.hs @@ -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 diff --git a/src/Matterhorn/State/Messages.hs b/src/Matterhorn/State/Messages.hs --- a/src/Matterhorn/State/Messages.hs +++ b/src/Matterhorn/State/Messages.hs @@ -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 diff --git a/src/Matterhorn/State/Messages.hs-boot b/src/Matterhorn/State/Messages.hs-boot --- a/src/Matterhorn/State/Messages.hs-boot +++ b/src/Matterhorn/State/Messages.hs-boot @@ -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 () diff --git a/src/Matterhorn/State/NotifyPrefs.hs b/src/Matterhorn/State/NotifyPrefs.hs --- a/src/Matterhorn/State/NotifyPrefs.hs +++ b/src/Matterhorn/State/NotifyPrefs.hs @@ -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 diff --git a/src/Matterhorn/State/PostListOverlay.hs b/src/Matterhorn/State/PostListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/State/PostListOverlay.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/State/PostListWindow.hs b/src/Matterhorn/State/PostListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/PostListWindow.hs @@ -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 diff --git a/src/Matterhorn/State/ReactionEmojiListOverlay.hs b/src/Matterhorn/State/ReactionEmojiListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/State/ReactionEmojiListOverlay.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/State/ReactionEmojiListWindow.hs b/src/Matterhorn/State/ReactionEmojiListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/ReactionEmojiListWindow.hs @@ -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 diff --git a/src/Matterhorn/State/Reactions.hs b/src/Matterhorn/State/Reactions.hs --- a/src/Matterhorn/State/Reactions.hs +++ b/src/Matterhorn/State/Reactions.hs @@ -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 () diff --git a/src/Matterhorn/State/SaveAttachmentWindow.hs b/src/Matterhorn/State/SaveAttachmentWindow.hs --- a/src/Matterhorn/State/SaveAttachmentWindow.hs +++ b/src/Matterhorn/State/SaveAttachmentWindow.hs @@ -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 diff --git a/src/Matterhorn/State/Setup.hs b/src/Matterhorn/State/Setup.hs --- a/src/Matterhorn/State/Setup.hs +++ b/src/Matterhorn/State/Setup.hs @@ -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 diff --git a/src/Matterhorn/State/Setup/Threads.hs b/src/Matterhorn/State/Setup/Threads.hs --- a/src/Matterhorn/State/Setup/Threads.hs +++ b/src/Matterhorn/State/Setup/Threads.hs @@ -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. diff --git a/src/Matterhorn/State/Teams.hs b/src/Matterhorn/State/Teams.hs --- a/src/Matterhorn/State/Teams.hs +++ b/src/Matterhorn/State/Teams.hs @@ -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 + } diff --git a/src/Matterhorn/State/Teams.hs-boot b/src/Matterhorn/State/Teams.hs-boot new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/Teams.hs-boot @@ -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 diff --git a/src/Matterhorn/State/ThemeListOverlay.hs b/src/Matterhorn/State/ThemeListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/State/ThemeListOverlay.hs +++ /dev/null @@ -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) diff --git a/src/Matterhorn/State/ThemeListWindow.hs b/src/Matterhorn/State/ThemeListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/ThemeListWindow.hs @@ -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) diff --git a/src/Matterhorn/State/ThreadWindow.hs b/src/Matterhorn/State/ThreadWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/ThreadWindow.hs @@ -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 () diff --git a/src/Matterhorn/State/ThreadWindow.hs-boot b/src/Matterhorn/State/ThreadWindow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/ThreadWindow.hs-boot @@ -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 () diff --git a/src/Matterhorn/State/UrlSelect.hs b/src/Matterhorn/State/UrlSelect.hs --- a/src/Matterhorn/State/UrlSelect.hs +++ b/src/Matterhorn/State/UrlSelect.hs @@ -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] diff --git a/src/Matterhorn/State/UserListOverlay.hs b/src/Matterhorn/State/UserListOverlay.hs deleted file mode 100644 --- a/src/Matterhorn/State/UserListOverlay.hs +++ /dev/null @@ -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 diff --git a/src/Matterhorn/State/UserListWindow.hs b/src/Matterhorn/State/UserListWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/State/UserListWindow.hs @@ -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 diff --git a/src/Matterhorn/State/Users.hs b/src/Matterhorn/State/Users.hs --- a/src/Matterhorn/State/Users.hs +++ b/src/Matterhorn/State/Users.hs @@ -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 diff --git a/src/Matterhorn/Themes.hs b/src/Matterhorn/Themes.hs --- a/src/Matterhorn/Themes.hs +++ b/src/Matterhorn/Themes.hs @@ -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] diff --git a/src/Matterhorn/Types.hs b/src/Matterhorn/Types.hs --- a/src/Matterhorn/Types.hs +++ b/src/Matterhorn/Types.hs @@ -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 diff --git a/src/Matterhorn/Types/Channels.hs b/src/Matterhorn/Types/Channels.hs --- a/src/Matterhorn/Types/Channels.hs +++ b/src/Matterhorn/Types/Channels.hs @@ -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 diff --git a/src/Matterhorn/Types/Core.hs b/src/Matterhorn/Types/Core.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Types/Core.hs @@ -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 + } diff --git a/src/Matterhorn/Types/DirectionalSeq.hs b/src/Matterhorn/Types/DirectionalSeq.hs --- a/src/Matterhorn/Types/DirectionalSeq.hs +++ b/src/Matterhorn/Types/DirectionalSeq.hs @@ -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 diff --git a/src/Matterhorn/Types/EditState.hs b/src/Matterhorn/Types/EditState.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Types/EditState.hs @@ -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) diff --git a/src/Matterhorn/Types/KeyEvents.hs b/src/Matterhorn/Types/KeyEvents.hs --- a/src/Matterhorn/Types/KeyEvents.hs +++ b/src/Matterhorn/Types/KeyEvents.hs @@ -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" diff --git a/src/Matterhorn/Types/MessageInterface.hs b/src/Matterhorn/Types/MessageInterface.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Types/MessageInterface.hs @@ -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 diff --git a/src/Matterhorn/Types/Messages.hs b/src/Matterhorn/Types/Messages.hs --- a/src/Matterhorn/Types/Messages.hs +++ b/src/Matterhorn/Types/Messages.hs @@ -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 = diff --git a/src/Matterhorn/Types/NonemptyStack.hs b/src/Matterhorn/Types/NonemptyStack.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Types/NonemptyStack.hs @@ -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 diff --git a/src/Matterhorn/Types/Posts.hs b/src/Matterhorn/Types/Posts.hs --- a/src/Matterhorn/Types/Posts.hs +++ b/src/Matterhorn/Types/Posts.hs @@ -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 diff --git a/src/Matterhorn/Types/RichText.hs b/src/Matterhorn/Types/RichText.hs --- a/src/Matterhorn/Types/RichText.hs +++ b/src/Matterhorn/Types/RichText.hs @@ -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. diff --git a/src/Matterhorn/Types/TabbedWindow.hs b/src/Matterhorn/Types/TabbedWindow.hs new file mode 100644 --- /dev/null +++ b/src/Matterhorn/Types/TabbedWindow.hs @@ -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 diff --git a/src/Matterhorn/Windows/ViewMessage.hs b/src/Matterhorn/Windows/ViewMessage.hs --- a/src/Matterhorn/Windows/ViewMessage.hs +++ b/src/Matterhorn/Windows/ViewMessage.hs @@ -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 diff --git a/test/Message_QCA.hs b/test/Message_QCA.hs --- a/test/Message_QCA.hs +++ b/test/Message_QCA.hs @@ -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 diff --git a/test/test_messages.hs b/test/test_messages.hs --- a/test/test_messages.hs +++ b/test/test_messages.hs @@ -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