matterhorn 50200.9.0 → 50200.10.0
raw patch · 57 files changed
+2092/−1407 lines, 57 filesdep ~brickdep ~mattermost-apidep ~mattermost-api-qc
Dependency ranges changed: brick, mattermost-api, mattermost-api-qc, vty
Files
- CHANGELOG.md +72/−0
- README.md +16/−317
- docs/commands.md +3/−1
- docs/keybindings.md +20/−2
- matterhorn.cabal +25/−12
- src/App.hs +2/−0
- src/Command.hs +21/−3
- src/Config.hs +3/−0
- src/Constants.hs +9/−0
- src/Draw.hs +4/−0
- src/Draw/Autocomplete.hs +1/−0
- src/Draw/ChannelList.hs +26/−23
- src/Draw/ChannelListOverlay.hs +4/−1
- src/Draw/ListOverlay.hs +57/−5
- src/Draw/Main.hs +13/−10
- src/Draw/Messages.hs +1/−1
- src/Draw/NotifyPrefs.hs +35/−0
- src/Draw/PostListOverlay.hs +1/−0
- src/Draw/ReactionEmojiListOverlay.hs +4/−1
- src/Draw/RichText.hs +525/−0
- src/Draw/ShowHelp.hs +127/−90
- src/Draw/TabbedWindow.hs +4/−7
- src/Draw/ThemeListOverlay.hs +53/−0
- src/Draw/URLList.hs +11/−7
- src/Draw/UserListOverlay.hs +4/−1
- src/Draw/Util.hs +10/−0
- src/Events.hs +13/−1
- src/Events/EditNotifyPrefs.hs +48/−0
- src/Events/Keybindings.hs +5/−0
- src/Events/Main.hs +2/−2
- src/Events/ManageAttachments.hs +5/−2
- src/Events/ThemeListOverlay.hs +30/−0
- src/Login.hs +16/−9
- src/Markdown.hs +0/−634
- src/State/Autocomplete.hs +3/−2
- src/State/ChannelSelect.hs +1/−0
- src/State/Channels.hs +25/−6
- src/State/Common.hs +2/−1
- src/State/MessageSelect.hs +4/−2
- src/State/Messages.hs +5/−1
- src/State/NotifyPrefs.hs +87/−0
- src/State/Setup.hs +1/−0
- src/State/ThemeListOverlay.hs +86/−0
- src/State/Themes.hs +0/−34
- src/State/UserListOverlay.hs +17/−10
- src/TeamSelect.hs +1/−1
- src/Themes.hs +116/−24
- src/Types.hs +115/−50
- src/Types/Channels.hs +14/−4
- src/Types/KeyEvents.hs +15/−0
- src/Types/Messages.hs +22/−52
- src/Types/Posts.hs +6/−13
- src/Types/RichText.hs +390/−0
- src/Types/UserNames.hs +0/−70
- src/Types/Users.hs +1/−4
- src/Windows/ViewMessage.hs +7/−1
- test/Message_QCA.hs +4/−3
CHANGELOG.md view
@@ -1,4 +1,76 @@ +50200.10.0+==========++New features:+ * Per-channel notification settings for non-DM channels can now be+ managed with the `/notify-prefs` command. As part of that change,+ themes got a new attribute, `brickForm.focusedInput`, that governs+ how focused form inputs are styled. (Thanks to Isaiah Mindich for+ this feature)+ * A new configuration file setting, `messageSelectAfterURLOpen`, was+ added to govern how URL opening works in message selection mode. When+ `False` (the default), opening URLs from a selected message returns+ the application to the main UI (the behavior prior to this release).+ When `True`, opening URLs leaves the application in message selection+ mode, allowing the user to continue opening URLs from other messages+ before returning to main mode manually.+ * The message viewing window now supports paging horizontally. This+ change adds two new key events:+ * `page-left` with default binding `Shift-Left`+ * `page-right` with default binding: `Shift-Right`+ * Matterhorn now sets the terminal window title based on unread+ activity (`matterhorn*` when there are unread messages; `matterhorn`+ otherwise.)+ * The `/theme` command now opens an interactive theme list window to+ choose between available built-in themes.+ * Added support for handling muted channels and respecting the `/mute`+ server command (thanks to Isaiah Mindich for this feature)+ * Make `Shift-Home`, not `Home`, selected the oldest message when in+ normal mode (#258). This change:+ * Changes the default keybinding for entering message selection mode+ and selecting the oldest message from `Home` to `Shift-Home`.+ * Adds a new key event, `select-oldest-message`, that `Shift-Home`+ triggers by default.+ * `Home` now triggers the `editor-home` event. Users wanting the+ old behavior can simply unbind the `editor-home` key event and+ bind `select-oldest-message` to `Home`.+ * New 256-color variants of the built-in light and dark themes were+ added. Those themes are identical to the 16-color variants except+ that larger pools of 256-color values are used to assign colors+ to usernames. If a username color chosen by the new themes is+ objectionable, it can be customized by first using the new+ `/username-attribute` command to find out which attribute is used+ to render a username and then setting it in the theme customization+ config. As part of this change the number of theme attributes for+ usernames was extended to 50, meaning attributes from `username.0` to+ `username.49` now govern the assignment of colors.++Other improvements:+ * The `/members` window now displays the total server user count in+ the title bar to avoid confusion about the number of displayed search+ results, which is capped by the server's API response.+ * Autocompletion now completes `@all` and `@channel` with prefix+ matches only and puts them after all other alternatives in the+ alternative list.+ * The help documentation on themes now documents the `#RRGGBB` theme+ color syntax that was already supported but not documented.+ * Key events now supported in the attachment management UI are now+ included in the keybinding help list.+ * The help documentation on themes now shows an attribute demo for each+ theme attribute using the current theme's colors.+ * Some documentation in the `README` was factored out into other+ documents in `docs/`.+ * The UI for showing typing notifications was improved.+ * The `/leave` command now hide DM and group channels instead of+ reporting an error (#626)++Bug fixes:+ * Matterhorn now properly restores the terminal state before crashing+ with unhandled exceptions (#622)+ * The URL list accessible with `C-o` now shows URLs from messages+ regardless of what kind of user reference they contain (#638)+ 50200.9.0 =========
README.md view
@@ -7,19 +7,6 @@  -# New Release Notifications--Get notified about new Matterhorn releases by following our Twitter account!--[https://twitter.com/matterhorn_chat](https://twitter.com/matterhorn_chat)--# Chat With the Developers--The Matterhorn developers hang out on the official Mattermost-community server. Stop by to get support and say hello!--[https://community.mattermost.com/core/channels/matterhorn](https://community.mattermost.com/core/channels/matterhorn)- # Quick Start We provide pre-built binary releases for some platforms. Please see the@@ -45,183 +32,18 @@ would download matterhorn version `30600.2.4`. See [Our Versioning Scheme](#our-versioning-scheme) for details. -# Authentication--`matterhorn` supports username/password authentication as well as-authentication by Personal Access Token or session token. The following-subsections provide details on using each method.--## Username / Password Authentication--Matterhorn's start-up login user interface will allow you to provide-a username and password for authentication. We recommend that you-put the username in your Matterhorn configuration file and configure-Matterhorn to obtain your password from your system keychain. See the-`docs/sample-config.ini` file for documentation on the `user` and-`passcmd` settings, respectively.--## Personal Access Token Authentication--Matterhorn's start-up login user interface will also allow you to-provide an session or Personal Access Token. If a token is provided, it-will take precedence over a username and password.--We recommend Personal Access Tokens because they don't expire except-when revoked. To use a Personal Access Token:--* Ask your Mattermost server administrator to enable Personal Access- Tokens on your Mattermost account.-* Create a Personal Access Token.-* Add the new token to your system keychain. (Details on how to do this- depend on your platform.)-* Configure Matterhorn's `tokencmd` configuration option to query the- system keychain to get the token. See `docs/sample-config.ini` for- examples of how to do this with `passcmd` and `tokencmd`.--The steps for configuring Personal Access Tokens can be found in [the-Mattermost documentation](https://docs.mattermost.com/developer/personal-access-tokens.html).--## Token Cookie Authentication--If your server does not support username and password authentication-(e.g. if GitLab authentication is the only supported method), you can-use your browser client's token cookie to authenticate:--* Authenticate to GitLab (or other identity provider) using the- Mattermost web client.-* Once your browser has returned to the Mattermost interace, obtain the- value of the `MMAUTHTOKEN` browser cookie.-* Start Matterhorn and enter the value of the `MMAUTHTOKEN` token in the- login interface field labeled `Access token:` or add the token to the- system keychain as described above.--Please note that unlike a Personal Access Token, the web client's token-cookie will expire, so these steps will need to be repeated each time-you log in with Matterhorn. As a result, we strongly recommend the use-of a Personal Access Token instead if at all possible.--Firefox users: you might consider using the-[mattermost-session-cookie-firefox](https://github.com/ftilde/mattermost-session-cookie-firefox)-script to make this process easier.--# Configuring--For configuration options you have two choices:--* Interactive configuration entered on each program run-* Configuration via stored settings in a config file--The first option is useful when trying out the program because you can-get up and running without worrying about making a configuration. Once-you're ready to make your settings persistent, they can be added to-a configuration file. An example configuration file can be found at-`docs/sample-config.ini`. Any settings omitted from the configuration-will be obtained interactively at startup.--When looking for configuration files, matterhorn will prefer-`config.ini` in the current working directory, but will look in the-typical XDG configuration directories (you'll probably want to use-`$HOME/.config/matterhorn/config.ini`) and as a last resort look for a-globally-accessible `/etc/matterhorn/config.ini`.--# Using the Client--The user interface has three main areas:--* Left: list of channels you're in, and list of users in your team and- their statuses (`+` means online, `-` means away, `×` means Do Not- Disturb, and an absent sigil means offline)-* Right: messages in the current channel-* Bottom: editing area for writing, editing, and replying to messages--You can use built-in keybindings or `/cmd`-style commands to operate the-client. Keybinding and command help may be obtained in a number of ways:--* The `/help` command within Matterhorn.-* The `F1` key within Matterhorn.-* Running matterhorn with the `-k` or `-m` arguments to get a text table of available keybindings or commands respectively.-* Running matterhorn with the `-k` or `-m` arguments with `-f markdown` to get a [Markdown table of available keybindings](docs/keybindings.md) or [Markdown table of available commands](docs/commands.md).-- Note: The keyboard and command output commands do not start the- client but simply print to stdout and exit. The keybindings shown- include any user overrides from the config files; use the `-i`- flag to skip loading the local config files and see the Matterhorn- default keybindings.--Keybindings may include modifiers such as Control (indicated with a-`C-` prefix) or Meta (indicated with a `M-` prefix). If your keyboard-has an `Alt` key, that will work as `Meta`. If it does not, you may be-able to configure your terminal to provide `Meta` via other means-(e.g. iTerm2 on OS X can be configured to make the left Option key-work as Meta). Keybindings can be customized in the configuration-file; see `/help keybindings` for details.--To join a channel, use the `/join` command to choose from a list of-available channels. To create a channel, use `/create-channel`. To leave-a channel, use `/leave-channel`.--To create a private group chat amongst yourself and other users, use the-`/group-msg` command, e.g., `/group-msg user1 user2`.--To see the members in the current channel, use the `/members` command.--To send a message, type it into the editor and press Enter to send.-To send a multi-line message, toggle multi-line mode with the default-binding `M-e`. Markdown syntax is accepted.--To edit your current message in an external editor (`$EDITOR`), use the-default binding of `M-k`.--To see a live preview of the message you're about to send while you-compose it (e.g. to check on how your Markdown syntax will be rendered),-toggle preview mode with the default binding `M-p`.--To change channels, use `/focus` or one of the default bindings `C-n`-(next channel), `C-p` (previous channel), `C-g` (fast channel switch).--To directly message another user, use `/focus` or `C-g`.--`C-g` channel switching mode does a substring match of the input text on-the channel and usernames; metacharacters `^` and `$` at the beginning-or end of input, respectively, anchor the match in case of multiple-matches. The cursor in this mode is usable with `C-n` and `C-p`.--To switch to the channel you were in prior to the current channel, use-the default binding `M-s` (swap). The most recent channel is marked in-the channel list with a "`<`" indicator.--To switch to the next channel with unread messages, use the default-binding `M-a`. Pressing `M-a` repeatedly will visit other channels with-unread messages, and the channel you started in when first pressing-`M-a` will be marked with `~` in the sidebar. Pressing `M-a` will return-to that channel after other channels with unread messages have been-visited.--To quickly show a list of URLs mentioned in the current channel and then-open one in your local browser, use the default binding of `C-o` and-configure the `urlOpenCommand` configuration setting.--To edit, delete, flag, or reply to a message, select a message with-the default binding of `C-s`. Use the default binding of `C-c` to-cancel these operations.--Messages that have been flagged can be viewed with either the `/flags`-command or `M-8`. This view allows you to select and unflag particular-messages, as well.+# Get Help! -To enable spell-checking in the message editor, install Aspell and set-`enableAspell` to `True` in your configuration. To override Aspell's-choice of master dictionary, set the `aspellDictionary` option to the-name of the dictionary you'd like to use.+We provide a number of avenues for getting support: -To attach a file to the post being edited, use the default binding of-`C-x`. The window that appears will let you browse the filesystem to-find a file to attach. In this window, `o` opens the selected file with-your URL open command to let you preview your choice, `Enter` enters the-selected directory or selects the current file for attachment, and arrow-keys change selection. Once you've attached a file, you'll see the text-`(1 attachment)` above your message editor. You can attach additional-files or remove existing attachments by pressing `C-x` again.+* [Frequently asked questions](docs/FAQ.md)+* [Matterhorn User Guide](docs/UserGuide.md)+* Built-in help (`/help`)+* [Command list](docs/commands.md)+* [Keybinding list](docs/keybindings.md)+* Chat with the developers on [the Mattermost Community server](https://community.mattermost.com/core/channels/matterhorn)+* Get notified about new Matterhorn releases by following+ [our Twitter account](https://twitter.com/matterhorn_chat) # Features @@ -240,6 +62,7 @@ * Rebindable keys (see `/help keybindings`) * Message editor with kill/yank buffer and readline-style keybindings * Support for adding and removing emoji post reactions+* Support for channel muting * Tab-completion of: * Usernames: type `@`, then `Tab` to cycle through matches * Channel names: type `~`, then `Tab` to cycle through matches@@ -262,45 +85,6 @@ `activityNotifyCommand` configuration setting and `docs/notification-scripts.md` for details). -# Spell Checking Support--Matterhorn uses `aspell` to perform spell-checking of your message-input. To use this feature:-- * Install `aspell` and ensure that your installation includes- dictionaries corresponding to your `LANG` setting. To check this, ask- `aspell` to check some input:- ```- $ echo stuff | aspell -a- Error: No word lists can be found for the language "en".- $ echo $LANG- en_US- ```- If Aspell succeeds, the output will look like this:- ```- @(#) International Ispell Version 3.1.20 (but really Aspell 0.60.6.1)- *- ```- * Set `enableAspell` to `True` in your `config.ini`- * Enter any message input in the message editor in `matterhorn`. After- a short delay after you stop typing, misspelled words will turn red.--# Emoji--Matterhorn loads its emoji list (for auto-completion of `:...:`) at-startup. It looks for an `emoji.json` file in the following locations-and in the following order:--* `~/.config/matterhorn/emoji.json`. This option is to support emoji- list installation and customization.-* `MHBIN/emoji/emoji.json`, where `MHBIN` is the directory containing- the `matterhorn` binary. This option is to make it convenient to use- emoji with `matterhorn` from releases.--The `emoji.json` is included in the Matterhorn releases-and is obtained from [the Mattermost web client source-tree](https://github.com/mattermost/mattermost-webapp/blob/master/utils/emoji.json).- # Our Versioning Scheme Matterhorn version strings will be of the form `ABBCC.X.Y` where ABBCC@@ -348,7 +132,7 @@ - If you are new to Haskell and are unsure how much Haskell you need to know in order to contribute, please see [our list of Haskell- skills needed](HASKELL.md).+ skills needed](docs/HASKELL.md). - Please base all patches against the `develop` branch unless you are specifically fixing a bug in a released version, in which case `master` is a fine place to start. Please also do this for submodules@@ -362,99 +146,14 @@ the codebase. - We follow a few development practices to support our project and it helps when contributors are aware of these. Please see- `docs/PRACTICES.md` for more information.+ [our practices document](docs/PRACTICES.md) for more information. -## Building+# Building If you just want to run Matterhorn, we strongly suggest running a binary release (see above). *Building from source is only recommended if you intend to contribute.* If you want to contribute changes to Matterhorn, you'll need to build-it from source. To do that you'll need an appropriate `ghc`/`cabal`-installation (see the latest Travis-CI builds for tested versions).-You'll also need a GitHub account, since our Git submodules are set up-to use SSH with GitHub. (But that should be fine since you'll need a-GitHub account to contribute anyway.)--`matterhorn` is built by running the following commands:--```-$ git pull-$ git submodule update --init-$ ./build.sh-```--# Frequently Asked Questions--## Does matterhorn support Gitlab authentication?--Matterhorn supports GitLab authentication indirectly. In order to use-Matterhorn with GitLab authentication, see the Authentication section on-Matterhorn details for use of session tokens.--## Does matterhorn support Mattermost Personal Access Tokens?--Yes. See the Authentication section above.--## How can I get Matterhorn to render emphasized Markdown text with an italic font?--In `~/.config/matterhorn/theme.ini`,-```-[other]-markdownEmph.style = [italic]-```-and in `~/.config/matterhorn/config.ini`,-```-themeCustomizationFile: theme.ini-```--This is known to work on `gnome-terminal` version `3.32.2`, VTE version-`0.56.3`; it may work for you, too. Many terminal emulators do not-support italics at all or without various hacks. Let us know what works-for you!--## I enabled italicized text in my theme configuration. Why doesn't it work?--Most terminfo files for typical terminal configurations do not provide-support for italicized text. If your terminal emulator supports italics,-you must enable it in your terminfo database in order to use it in-Matterhorn. For more information, see these links:--* http://www.nerdyweekly.com/posts/enable-italic-text-vim-tmux-gnome-terminal/-* https://medium.com/@dubistkomisch/how-to-actually-get-italics-and-true-colour-to-work-in-iterm-tmux-vim-9ebe55ebc2be-* https://github.com/tmux/tmux/blob/2.1/FAQ#L355-L383--## I am seeing malformed characters or display corruption when I run matterhorn in my terminal. What could be causing this?--Some terminal emulators cannot handle the extra escaping that occurs-when the URL hyperlinking mode is enabled. Try setting `hyperlinkUrls =-False` in your `config.ini` file.--## Does Matterhorn support graphical emoji?--At present Matterhorn does not reliably support graphical emoji due to-the lack of consistent support for wide Unicode characters in various-terminal emulators. Results may vary, and use of emoji characters may-cause terminal rendering issues depending on the terminal emulator in-use.--## I'm running Matterhorn in Tmux. How can I paste tmux buffers into Matterhorn's editor?--By default, `tmux`'s `paste-buffer` binding, `prefix-]`, pastes buffer-text by replaying it as terminal input. This will cause unwanted-behavior when Matterhorn receives that text and sends out each input-line as a separate message. But `tmux` supports bracketed paste mode-to make a `tmux` paste a block of text as *one* Matterhorn message.-It can be enabled by changing the behavior of `prefix-]` in the Tmux-configuration:--```-unbind-key -T prefix ]-bind-key -T prefix ] paste-buffer -p-```--## I'm using Mattermost through an Nginx proxy and I keep getting disconnected.--You might need to adjust your Nginx proxy settings.-For context, see [this potentially related report](https://github.com/matterhorn-chat/matterhorn/issues/578).+it from source. See [our building instructions](docs/BUILDING.md) for+details.
docs/commands.md view
@@ -16,7 +16,7 @@ | `/hide` | Hide the current DM or group channel from the channel list | | `/join` | Find a channel to join | | `/join <~channel>` | Join the specified channel |-| `/leave` | Leave the current channel |+| `/leave` | Leave a normal channel or hide a DM channel | | `/left` | Focus on the previous channel | | `/log-mark <message>` | Add a custom marker message to the Matterhorn debug log | | `/log-snapshot <path>` | Dump the current debug log buffer to the specified path |@@ -29,6 +29,7 @@ | `/msg` | Search for a user to enter a private chat | | `/msg <@user>` | Chat with the specified user | | `/msg <@user> <message or command>` | Go to a user's channel and send the specified message or command |+| `/notify-prefs` | Edit the current channel's notification preferences | | `/pinned-posts` | Open a window of this channel's pinned posts | | `/purpose <purpose>` | Set the current channel's purpose | | `/quit` | Exit Matterhorn |@@ -44,3 +45,4 @@ | `/toggle-channel-list` | Toggle channel list visibility | | `/topic <topic>` | Set the current channel's topic (header) | | `/user` | Show users to initiate a private DM chat channel |+| `/username-attribute <@user>` | Display the attribute used to color the specified username |
docs/keybindings.md view
@@ -23,7 +23,7 @@ | `C-r` | `reply-recent` | Reply to the most recent message | | `M-p` | `toggle-message-preview` | Toggle message preview | | `F2` | `toggle-channel-list-visibility` | Toggle channel list visibility |-| `M-k` | `invoke-editor` | Invoke *$EDITOR* to edit the current message |+| `M-k` | `invoke-editor` | Invoke `$EDITOR` to edit the current message | | `C-g` | `enter-fast-select` | Enter fast channel selection mode | | `C-q` | `quit` | Quit | | `Tab` | (non-customizable key) | Tab-complete forward |@@ -31,7 +31,7 @@ | `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) |-| `Home` | `scroll-top` | Scroll to top of channel message list |+| `S-Home` | `select-oldest-message` | Scroll to top of channel message list | | `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 '~' |@@ -114,6 +114,16 @@ | `f` | `flag-message` | Toggle the selected message flag | | `Enter` | `activate-list-item` | Jump to and select current message | +# Theme List Window+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Close the theme list |+| `C-p`, `Up` | `search-select-up` | Select the previous theme |+| `C-n`, `Down` | `search-select-down` | Select the next theme |+| `PgDown` | `page-down` | Page down in the theme list |+| `PgUp` | `page-up` | Page up in the theme list |+| `Enter` | `activate-list-item` | Switch to the selected color theme |+ # User Listings | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |@@ -156,6 +166,8 @@ | ---------- | ---------- | ----------- | | `PgUp` | `page-up` | Page up | | `PgDown` | `page-down` | Page down |+| `S-Left` | `page-left` | Page left |+| `S-Right` | `page-right` | Page right | | `Up` | `scroll-up` | Scroll up | | `Down` | `scroll-down` | Scroll down | | `Left` | `scroll-left` | Scroll left |@@ -182,4 +194,10 @@ | `a` | `add-to-attachment-list` | Add a new attachment to the attachment list | | `o` | `open-attachment` | Open the selected attachment using the URL open command | | `d` | `delete-from-attachment-list` | Delete the selected attachment from the attachment list |++# Attachment File Browser+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Cancel attachment file browse |+| `o` | `open-attachment` | Open the selected file using the URL open command |
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.9.0+version: 50200.10.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@@ -59,13 +59,14 @@ State.Logging State.Messages State.MessageSelect+ State.NotifyPrefs State.PostListOverlay+ State.ThemeListOverlay State.ReactionEmojiListOverlay State.Reactions State.Setup State.Setup.Threads State.Setup.Threads.Logging- State.Themes State.UrlSelect State.ListOverlay State.UserListOverlay@@ -75,6 +76,7 @@ Themes Draw Emoji+ Draw.RichText Draw.ManageAttachments Draw.Autocomplete Draw.Main@@ -86,11 +88,13 @@ Draw.LeaveChannelConfirm Draw.DeleteChannelConfirm Draw.PostListOverlay+ Draw.ThemeListOverlay Draw.UserListOverlay Draw.ListOverlay Draw.URLList Draw.Util Draw.TabbedWindow+ Draw.NotifyPrefs InputHistory IOUtil Events@@ -101,6 +105,7 @@ Events.Main Events.ChannelSelect Events.PostListOverlay+ Events.ThemeListOverlay Events.UrlSelect Events.UserListOverlay Events.ChannelListOverlay@@ -108,6 +113,7 @@ Events.LeaveChannelConfirm Events.DeleteChannelConfirm Events.TabbedWindow+ Events.EditNotifyPrefs Windows.ViewMessage HelpTopics KeyMap@@ -121,22 +127,25 @@ Types.DirectionalSeq Types.KeyEvents Types.Messages+ Types.RichText Types.Users- Types.UserNames Types.Posts FilePaths TeamSelect Login- Markdown Options Util Paths_matterhorn default-extensions: OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude+ ghc-options: -Wall -threaded -with-rtsopts=-I0 -Wcompat+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths+ build-depends: base >=4.8 && <5- , mattermost-api == 50200.6.0+ , mattermost-api == 50200.7.0 , base-compat >= 0.9 && < 0.12 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7@@ -150,9 +159,9 @@ , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.5- , brick >= 0.52.1 && < 0.53+ , brick >= 0.55 && < 0.56 , brick-skylighting >= 0.2 && < 0.4- , vty >= 5.28 && < 5.29+ , vty >= 5.30 && < 5.31 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11@@ -190,18 +199,22 @@ , TimeUtils , Types.Messages , Types.Posts- , Types.UserNames , Types.Common , Types.DirectionalSeq+ , Types.RichText+ , Constants , Prelude.MH default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables ghc-options: -Wall -fno-warn-orphans -Wcompat+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths+ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.12- , brick >= 0.52.1 && < 0.53+ , brick >= 0.55 && < 0.56 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.6@@ -212,8 +225,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.4 , Hclip >= 3.0 && < 3.1- , mattermost-api == 50200.6.0- , mattermost-api-qc == 50200.6.0+ , mattermost-api == 50200.7.0+ , mattermost-api-qc == 50200.7.0 , microlens-platform >= 0.3 && < 0.5 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -233,7 +246,7 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector < 0.13- , vty >= 5.28 && < 5.29+ , vty >= 5.30 && < 5.31 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.20 , uuid >= 1.3 && < 1.4
src/App.hs view
@@ -38,6 +38,7 @@ ReactionEmojiListOverlay -> showFirstCursor s cs ChannelListOverlay -> showFirstCursor s cs ManageAttachmentsBrowseFiles -> showFirstCursor s cs+ ThemeListOverlay -> showFirstCursor s cs LeaveChannelConfirm -> Nothing DeleteChannelConfirm -> Nothing MessageSelect -> Nothing@@ -47,6 +48,7 @@ ViewMessage -> Nothing ShowHelp _ _ -> Nothing UrlSelect -> Nothing+ EditNotifyPrefs -> Nothing , appHandleEvent = Events.onEvent , appStartEvent = return , appAttrMap = (^.csResources.crTheme)
src/Command.hs view
@@ -22,6 +22,7 @@ import qualified Network.Mattermost.Types as MM import Connection ( connectWebsockets )+import Constants ( userSigil, normalChannelSigil ) import HelpTopics import Scripts import State.Help@@ -30,10 +31,13 @@ import State.ChannelSelect import State.Logging import State.PostListOverlay-import State.Themes import State.UserListOverlay import State.ChannelListOverlay+import State.ThemeListOverlay+import State.NotifyPrefs+import State.Common ( postInfoMessage ) import State.Users+import Themes ( attrForUsername ) import Types @@ -120,7 +124,7 @@ NoArg $ \ () -> enterChannelMembersUserList - , Cmd "leave" "Leave the current channel" NoArg $ \ () ->+ , Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () -> startLeaveCurrentChannel , Cmd "join" "Find a channel to join" NoArg $ \ () ->@@ -130,7 +134,7 @@ joinChannelByName n , Cmd "theme" "List the available themes" NoArg $ \ () ->- listThemes+ enterThemeListMode , Cmd "theme" "Set the color theme" (TokenArg "theme" NoArg) $ \ (themeName, ()) ->@@ -156,6 +160,10 @@ (UserArg NoArg) $ \ (name, ()) -> changeChannelByName name + , Cmd "username-attribute" "Display the attribute used to color the specified username"+ (UserArg NoArg) $ \ (name, ()) ->+ displayUsernameAttribute name+ , Cmd "msg" "Go to a user's channel and send the specified message or command" (UserArg $ LineArg "message or command") $ \ (name, msg) -> do withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do@@ -248,7 +256,17 @@ , Cmd "search" "Search for posts with given terms" (LineArg "terms") $ enterSearchResultPostListMode + , Cmd "notify-prefs" "Edit the current channel's notification preferences" NoArg $ \_ ->+ enterEditNotifyPrefsMode+ ]++displayUsernameAttribute :: Text -> MH ()+displayUsernameAttribute name = do+ let an = attrForUsername trimmed+ trimmed = trimUserSigil name+ postInfoMessage $ "The attribute used for " <> userSigil <> trimmed <>+ " is " <> (attrNameToConfig an) execMMCommand :: Text -> Text -> MH () execMMCommand name rest = do
src/Config.hs view
@@ -111,6 +111,8 @@ (configActivityBell defaultConfig) configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs" (configHyperlinkingMode defaultConfig)+ configMessageSelectAfterURLOpen <- fieldFlagDef "messageSelectAfterURLOpen"+ (configMessageSelectAfterURLOpen defaultConfig) configPass <- (Just . PasswordCommand <$> field "passcmd") <!> (Just . PasswordString <$> field "pass") <!> pure Nothing@@ -241,6 +243,7 @@ , configUserKeys = mempty , configShowTypingIndicator = False , configHyperlinkingMode = True+ , configMessageSelectAfterURLOpen = False , configSyntaxDirs = [] , configDirectChannelExpirationDays = 7 , configCpuUsagePolicy = MultipleCPUs
src/Constants.hs view
@@ -3,6 +3,8 @@ , userTypingExpiryInterval , numScrollbackPosts , previewMaxHeight+ , normalChannelSigil+ , userSigil ) where @@ -24,3 +26,10 @@ -- | The maximum height of the message preview, in lines. previewMaxHeight :: Int previewMaxHeight = 5++-- Sigils+normalChannelSigil :: Text+normalChannelSigil = "~"++userSigil :: Text+userSigil = "@"
src/Draw.hs view
@@ -12,6 +12,7 @@ import Draw.DeleteChannelConfirm import Draw.LeaveChannelConfirm import Draw.Main+import Draw.ThemeListOverlay import Draw.PostListOverlay import Draw.ShowHelp import Draw.UserListOverlay@@ -19,6 +20,7 @@ import Draw.ReactionEmojiListOverlay import Draw.TabbedWindow import Draw.ManageAttachments+import Draw.NotifyPrefs import Types @@ -33,6 +35,7 @@ MessageSelect -> drawMain True st MessageSelectDeleteConfirm -> drawMain True st DeleteChannelConfirm -> drawDeleteChannelConfirm st+ ThemeListOverlay -> drawThemeListOverlay st PostListOverlay contents -> drawPostListOverlay contents st UserListOverlay -> drawUserListOverlay st ChannelListOverlay -> drawChannelListOverlay st@@ -40,3 +43,4 @@ ViewMessage -> drawTabbedWindow (st^.csViewedMessage.singular _Just._2) st : drawMain False st ManageAttachments -> drawManageAttachments st ManageAttachmentsBrowseFiles -> drawManageAttachments st+ EditNotifyPrefs -> drawNotifyPrefs st : drawMain False st
src/Draw/Autocomplete.hs view
@@ -15,6 +15,7 @@ import Network.Mattermost.Types ( User(..), Channel(..) ) +import Constants ( normalChannelSigil ) import Draw.Util import Themes import Types
src/Draw/ChannelList.hs view
@@ -29,6 +29,7 @@ import qualified Network.Mattermost.Types as MM +import Constants ( userSigil ) import Draw.Util import State.Channels import Themes@@ -47,6 +48,7 @@ , entryIsRecent :: Bool , entryIsReturn :: Bool , entryIsCurrent :: Bool+ , entryIsMuted :: Bool , entryUserStatus :: Maybe UserStatus } @@ -82,12 +84,12 @@ (renderChannelListGroup st (\s e -> renderChannelListEntry myUsername_ $ mkChannelEntryData s e) <$> Z.toList (st^.csFocus)) -renderChannelListGroupHeading :: ChannelListGroup -> Bool -> Widget Name-renderChannelListGroupHeading g anyUnread =- let label = case g of- ChannelGroupPublicChannels -> "Public Channels"- ChannelGroupPrivateChannels -> "Private Channels"- ChannelGroupDirectMessages -> "Direct Messages"+renderChannelListGroupHeading :: ChannelListGroup -> Widget Name+renderChannelListGroupHeading g =+ let (anyUnread, label) = case g of+ ChannelGroupPublicChannels u -> (u, "Public Channels")+ ChannelGroupPrivateChannels u -> (u, "Private Channels")+ ChannelGroupDirectMessages u -> (u, "Direct Messages") addUnread = if anyUnread then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*")) else id@@ -95,14 +97,12 @@ in hBorderWithLabel labelWidget renderChannelListGroup :: ChatState- -> (ChatState -> e -> (Bool, Widget Name))+ -> (ChatState -> e -> Widget Name) -> (ChannelListGroup, [e]) -> Widget Name renderChannelListGroup st renderEntry (group, es) =- let heading = renderChannelListGroupHeading group anyUnread- entryResults = renderEntry st <$> es- (unreadFlags, entryWidgets) = unzip entryResults- anyUnread = or unreadFlags+ let heading = renderChannelListGroupHeading group+ entryWidgets = renderEntry st <$> es in if null entryWidgets then emptyWidget else vBox (heading : entryWidgets)@@ -111,7 +111,7 @@ -> ChannelListEntry -> ChannelListEntryData mkChannelEntryData st e =- ChannelListEntryData sigilWithSpace name unread mentions recent ret current status+ ChannelListEntryData sigilWithSpace name unread mentions recent ret current muted status where cId = channelListEntryChannelId e Just chan = findChannelById cId (st^.csChannels)@@ -119,6 +119,7 @@ recent = isRecentChannel st cId ret = isReturnChannel st cId current = isCurrentChannel st cId+ muted = isMuted chan (name, normalSigil, addSpace, status) = case e of CLChannel _ -> (chan^.ccInfo.cdDisplayName, Nothing, False, Nothing)@@ -144,14 +145,14 @@ -- | Render an individual Channel List entry (in Normal mode) with -- appropriate visual decorations.-renderChannelListEntry :: Text -> ChannelListEntryData -> (Bool, Widget Name)-renderChannelListEntry myUName entry = (entryHasUnread entry, body)+renderChannelListEntry :: Text -> ChannelListEntryData -> Widget Name+renderChannelListEntry myUName entry = body where body = decorate $ decorateEntry entry $ decorateMentions $ padRight Max $ entryWidget $ entrySigil entry <> entryLabel entry decorate = if | entryIsCurrent entry -> visible . forceAttr currentChannelNameAttr- | entryMentions entry > 0 ->+ | entryMentions entry > 0 && not (entryIsMuted entry) -> forceAttr mentionsChannelAttr | entryHasUnread entry -> forceAttr unreadChannelAttr@@ -165,25 +166,27 @@ (<+> str "(9+)") | entryMentions entry > 0 = (<+> str ("(" <> show (entryMentions entry) <> ")"))+ | entryIsMuted entry =+ (<+> str "(m)") | otherwise = id -- | Render an individual entry when in Channel Select mode, -- highlighting the matching portion, or completely suppressing the -- entry if it doesn't match.-renderChannelSelectListEntry :: Maybe ChannelSelectMatch -> ChatState -> ChannelSelectMatch -> (Bool, Widget Name)+renderChannelSelectListEntry :: Maybe ChannelSelectMatch -> ChatState -> ChannelSelectMatch -> Widget Name renderChannelSelectListEntry curMatch st match = let ChannelSelectMatch preMatch inMatch postMatch _ entry = match maybeSelect = if (Just entry) == (matchEntry <$> curMatch) then visible . withDefAttr currentChannelNameAttr else id entryData = mkChannelEntryData st entry- in (False, maybeSelect $- decorateEntry entryData $- padRight Max $- hBox [ txt $ entrySigil entryData <> preMatch- , forceAttr channelSelectMatchAttr $ txt inMatch- , txt postMatch- ])+ in maybeSelect $+ decorateEntry entryData $+ padRight Max $+ hBox [ txt $ entrySigil entryData <> preMatch+ , forceAttr channelSelectMatchAttr $ txt inMatch+ , txt postMatch+ ] -- If this channel is the return channel, add a decoration to denote -- that.
src/Draw/ChannelListOverlay.hs view
@@ -14,7 +14,7 @@ import Network.Mattermost.Lenses import Draw.Main-import Draw.ListOverlay ( drawListOverlay )+import Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) ) import Types import Types.Common ( sanitizeUserText ) import Themes@@ -25,6 +25,9 @@ let overlay = drawListOverlay (st^.csChannelListOverlay) channelSearchScopeHeader channelSearchScopeNoResults channelSearchScopePrompt renderChannel+ Nothing+ OverlayCenter+ 80 in joinBorders overlay : drawMain False st channelSearchScopePrompt :: ChannelSearchScope -> Widget Name
src/Draw/ListOverlay.hs view
@@ -3,6 +3,7 @@ module Draw.ListOverlay ( drawListOverlay+ , OverlayPosition(..) ) where @@ -17,7 +18,8 @@ import Control.Monad.Trans.Reader ( withReaderT ) import qualified Data.Foldable as F import qualified Data.Text as T-import Lens.Micro.Platform ( (%~) )+import Graphics.Vty ( imageWidth, translateX)+import Lens.Micro.Platform ( (%~), (.~), to ) import Themes import Types@@ -31,6 +33,11 @@ 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.@@ -48,15 +55,33 @@ -> (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 =- centerLayer $ hLimitWithPadding 10 $ vLimit 25 $- borderWithLabel (withDefAttr clientEmphAttr $ scopeHeader scope) body+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"@@ -66,7 +91,20 @@ else case st^.listOverlaySearchResults.L.listSelectedL of Nothing -> hBorder Just _ ->- let msg = "Found " <> show numSearchResults <> " result" <> plural numSearchResults+ 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@@ -80,3 +118,17 @@ renderedUserList = L.renderList renderItem True (st^.listOverlaySearchResults) numSearchResults = F.length $ st^.listOverlaySearchResults.L.listElementsL++upperRightLayer :: Widget a -> Widget a+upperRightLayer w =+ Widget (hSize w) (vSize w) $ do+ result <- render w+ c <- getContext+ let rWidth = result^.imageL.to imageWidth+ leftPaddingAmount = max 0 $ c^.availWidthL - rWidth+ paddedImage = translateX leftPaddingAmount $ result^.imageL+ off = Location (leftPaddingAmount, 0)+ if leftPaddingAmount == 0 then+ return result else+ return $ addResultOffset off+ $ result & imageL .~ paddedImage
src/Draw/Main.hs view
@@ -33,13 +33,14 @@ import Draw.Autocomplete import Draw.URLList import Draw.Util+import Draw.RichText import Events.Keybindings import Events.MessageSelect-import Markdown import State.MessageSelect import Themes import TimeUtils ( justAfter, justBefore ) import Types+import Types.RichText ( parseMarkdown ) import Types.KeyEvents @@ -56,7 +57,7 @@ msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy in if isCommand && not isEmoteCmd then Nothing- else Just $ Message { _mText = getBlocks content+ else Just $ Message { _mText = parseMarkdown content , _mMarkdownSource = content , _mUser = UserI False uId , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0@@ -626,14 +627,16 @@ , txt " to manage)" ] - showTypingUsers = case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of- [] -> emptyWidget- [uId] | Just un <- usernameForUserId uId st ->- txt $ un <> " is typing"- [uId1, uId2] | Just un1 <- usernameForUserId uId1 st- , Just un2 <- usernameForUserId uId2 st ->- txt $ un1 <> " and " <> un2 <> " are typing"- _ -> txt "several people are typing"+ showTypingUsers =+ let format = renderText' (myUsername st) hs+ in case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of+ [] -> emptyWidget+ [uId] | Just un <- usernameForUserId uId st ->+ format $ "[" <> userSigil <> un <> " is typing]"+ [uId1, uId2] | Just un1 <- usernameForUserId uId1 st+ , Just un2 <- usernameForUserId uId2 st ->+ format $ "[" <> userSigil <> un1 <> " and " <> userSigil <> un2 <> " are typing]"+ _ -> format "[several people are typing]" showBusy = case st^.csWorkerIsBusy of Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)
src/Draw/Messages.hs view
@@ -18,7 +18,7 @@ import Prelude.MH import Draw.Util-import Markdown+import Draw.RichText import Themes import Types import Types.DirectionalSeq
+ src/Draw/NotifyPrefs.hs view
@@ -0,0 +1,35 @@+module Draw.NotifyPrefs+ ( drawNotifyPrefs+ )+where++import Prelude ()+import Prelude.MH++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Brick.Forms (renderForm)+import Data.List (intersperse)++import Draw.Util (renderKeybindingHelp)+import Types+import Types.KeyEvents+import Themes++drawNotifyPrefs :: ChatState -> Widget Name+drawNotifyPrefs st =+ let Just form = st^.csNotifyPrefs+ label = forceAttr clientEmphAttr $ str "Notification Preferences"+ formKeys = withDefAttr clientEmphAttr <$> txt <$> ["Tab", "BackTab"]+ bindings = vBox $ hCenter <$> [ renderKeybindingHelp "Save" [FormSubmitEvent] <+> txt " " <+>+ renderKeybindingHelp "Cancel" [CancelEvent]+ , hBox ((intersperse (txt "/") formKeys) <> [txt (":Cycle form fields")])+ , hBox [withDefAttr clientEmphAttr $ txt "Space", txt ":Toggle form field"]+ ]+ in centerLayer $+ vLimit 25 $+ hLimit 39 $+ joinBorders $+ borderWithLabel label $+ (padAll 1 $ renderForm form) <=> hBorder <=> bindings
src/Draw/PostListOverlay.hs view
@@ -16,6 +16,7 @@ import Network.Mattermost.Lenses import Network.Mattermost.Types +import Constants ( userSigil ) import Draw.Main import Draw.Messages import Draw.Util
src/Draw/ReactionEmojiListOverlay.hs view
@@ -11,7 +11,7 @@ import qualified Data.Text as T import Draw.Main-import Draw.ListOverlay ( drawListOverlay )+import Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) ) import Types import Themes @@ -23,6 +23,9 @@ (const $ txt "No matching emoji found.") (const $ txt "Search emoji:") renderEmoji+ Nothing+ OverlayCenter+ 80 in joinBorders overlay : drawMain False st renderEmoji :: Bool -> (Bool, T.Text) -> Widget Name
+ src/Draw/RichText.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE RecordWildCards #-}+module Draw.RichText+ ( MessageData(..)+ , renderRichText+ , renderMessage+ , renderText+ , renderText'+ , renderElementSeq+ , cursorSentinel+ , addEllipsis+ , findVerbatimChunk+ )+where++import Prelude ()+import Prelude.MH++import Brick ( (<+>), Widget, hLimit, imageL+ , raw, render, Size(..), Widget(..)+ )+import qualified Brick as B+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Skylighting as BS+import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import Data.Sequence ( ViewL(..)+ , ViewR(..)+ , (<|)+ , (|>)+ , viewl+ , viewr)+import qualified Data.Sequence as S+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Graphics.Vty as V+import qualified Skylighting.Core as Sky++import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )+import Network.Mattermost.Types ( ServerTime(..) )++import Constants ( normalChannelSigil, userSigil )+import Themes+import Types ( Name, HighlightSet(..) )+import Types.Messages+import Types.Posts+import Types.RichText+++emptyHSet :: HighlightSet+emptyHSet = HighlightSet Set.empty Set.empty mempty++omittedUsernameType :: MessageType -> Bool+omittedUsernameType = \case+ CP Join -> True+ CP Leave -> True+ CP TopicChange -> True+ _ -> False++-- Add the edit sentinel to the end of the last block in the sequence.+-- If the last block is a paragraph, append it to that paragraph.+-- Otherwise, append a new block so it appears beneath the last+-- block-level element.+addEditSentinel :: ElementData -> Seq RichTextBlock -> Seq RichTextBlock+addEditSentinel d bs =+ case viewr bs of+ EmptyR -> bs+ (rest :> b) -> rest <> appendEditSentinel d b++appendEditSentinel :: ElementData -> RichTextBlock -> Seq RichTextBlock+appendEditSentinel sentinel b =+ let s = Para (S.singleton m)+ m = Element Normal sentinel+ in case b of+ Para is -> S.singleton $ Para (is |> Element Normal ESpace |> m)+ _ -> S.fromList [b, s]++-- | A bundled structure that includes all the information necessary+-- to render a given message+data MessageData =+ MessageData { mdEditThreshold :: Maybe ServerTime+ -- ^ If specified, any messages edited before this point+ -- in time are not indicated as edited.+ , mdShowOlderEdits :: Bool+ -- ^ Indicates whether "edited" markers should be shown+ -- for old messages (i.e., ignore the mdEditThreshold+ -- value).+ , mdShowReactions :: Bool+ -- ^ Whether to render reactions.+ , mdMessage :: Message+ -- ^ The message to render.+ , mdUserName :: Maybe Text+ -- ^ The username of the message's author, if any. This+ -- is passed here rather than obtaining from the message+ -- because we need to do lookups in the ChatState to+ -- compute this, and we don't pass the ChatState into+ -- renderMessage.+ , mdParentMessage :: Maybe Message+ -- ^ The parent message of this message, if any.+ , mdParentUserName :: Maybe Text+ -- ^ The author of the parent message, if any.+ , mdThreadState :: ThreadState+ -- ^ The thread state of this message.+ , mdRenderReplyParent :: Bool+ -- ^ Whether to render the parent message.+ , mdHighlightSet :: HighlightSet+ -- ^ The highlight set to use to highlight usernames,+ -- channel names, etc.+ , mdIndentBlocks :: Bool+ -- ^ Whether to indent the message underneath the+ -- author's name (True) or just display it to the right+ -- of the author's name (False).+ , mdMessageWidthLimit :: Maybe Int+ -- ^ A width override to use to wrap non-code blocks. If+ -- unspecified, all blocks in the message will be+ -- wrapped and truncated at the width specified by the+ -- rendering context. If specified, all non-code blocks+ -- will be wrapped at this width and code blocks will be+ -- rendered using the context's width.+ , mdMyUsername :: Text+ -- ^ The username of the user running Matterhorn.+ }++-- | renderMessage performs markdown rendering of the specified message.+renderMessage :: MessageData -> Widget Name+renderMessage md@MessageData { mdMessage = msg, .. } =+ let msgUsr = case mdUserName of+ Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u+ Nothing -> Nothing+ botElem = if isBotMessage msg then B.txt "[BOT]" else B.emptyWidget+ nameElems = case msgUsr of+ Just un+ | isEmote msg ->+ [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN]" else ""+ , B.txt $ (if msg^.mFlagged then "[!] " else "") <> "*"+ , colorUsername mdMyUsername un un+ , botElem+ , B.txt " "+ ]+ | otherwise ->+ [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN] " else ""+ , colorUsername mdMyUsername un un+ , botElem+ , B.txt $ (if msg^.mFlagged then "[!]" else "") <> ": "+ ]+ Nothing -> []++ -- Use the editing threshold to determine whether to append an+ -- editing indication to this message.+ maybeAugment bs = case msg^.mOriginalPost of+ Nothing -> bs+ Just p ->+ if p^.postEditAtL > p^.postCreateAtL+ then case mdEditThreshold of+ Just cutoff | p^.postEditAtL >= cutoff ->+ addEditSentinel (EEditSentinel True) bs+ _ -> if mdShowOlderEdits+ then addEditSentinel (EEditSentinel False) bs+ else bs+ else bs++ augmentedText = maybeAugment $ msg^.mText+ msgWidget =+ vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText :+ catMaybes [msgAtch, msgReac]+ replyIndent = B.Widget B.Fixed B.Fixed $ do+ ctx <- B.getContext+ -- NB: The amount subtracted here must be the total padding+ -- added below (pad 1 + vBorder)+ w <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) msgWidget+ B.render $ B.vLimit (V.imageHeight $ w^.B.imageL) $+ B.padRight (B.Pad 1) B.vBorder B.<+> (B.Widget B.Fixed B.Fixed $ return w)+ msgAtch = if Seq.null (msg^.mAttachments)+ then Nothing+ else Just $ B.withDefAttr clientMessageAttr $ vBox+ [ B.txt (" [attached: `" <> a^.attachmentName <> "`]")+ | a <- toList (msg^.mAttachments)+ ]+ msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions)+ then Nothing+ else let renderR e us =+ let n = Set.size us+ in if | n == 1 -> " [" <> e <> "]"+ | n > 1 -> " [" <> e <> " " <> T.pack (show n) <> "]"+ | otherwise -> ""+ reactionMsg = Map.foldMapWithKey renderR (msg^.mReactions)+ in Just $ B.withDefAttr emojiAttr $ B.txt (" " <> reactionMsg)+ withParent p =+ case mdThreadState of+ NoThread -> msgWidget+ InThreadShowParent -> p B.<=> replyIndent+ InThread -> replyIndent+ in if not mdRenderReplyParent+ then msgWidget+ else case msg^.mInReplyToMsg of+ NotAReply -> msgWidget+ InReplyTo _ ->+ case mdParentMessage of+ Nothing -> withParent (B.str "[loading...]")+ Just pm ->+ let parentMsg = renderMessage md+ { mdShowOlderEdits = False+ , mdMessage = pm+ , mdUserName = mdParentUserName+ , mdParentMessage = Nothing+ , mdRenderReplyParent = False+ , mdIndentBlocks = False+ }+ in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg)++ where+ layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq RichTextBlock+ -> ViewL RichTextBlock -> Widget Name+ layout hs w nameElems bs xs | length xs > 1 = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (Blockquote {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (CodeBlock {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (HTMLBlock {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (List {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (Para inlns :< _)+ | F.any breakCheck inlns = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs _ = nameNextToMessage hs w nameElems bs++ multiLnLayout hs w nameElems bs =+ if mdIndentBlocks+ then vBox [ hBox nameElems+ , hBox [B.txt " ", renderRichText mdMyUsername hs ((subtract 2) <$> w) bs]+ ]+ else nameNextToMessage hs w nameElems bs++ nameNextToMessage hs w nameElems bs =+ Widget Fixed Fixed $ do+ nameResult <- render $ hBox nameElems+ let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w+ render $ hBox [raw (nameResult^.imageL), renderRichText mdMyUsername hs newW bs]++ breakCheck e = eData e `elem` [ELineBreak, ESoftBreak]++addEllipsis :: Widget a -> Widget a+addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do+ ctx <- B.getContext+ let aw = ctx^.B.availWidthL+ result <- B.render w+ let withEllipsis = (B.hLimit (aw - 3) $ B.vLimit 1 $ (B.Widget B.Fixed B.Fixed $ return result)) <+>+ B.str "..."+ if (V.imageHeight (result^.B.imageL) > 1) || (V.imageWidth (result^.B.imageL) == aw) then+ B.render withEllipsis else+ return result++-- Cursor sentinel for tracking the user's cursor position in previews.+cursorSentinel :: Char+cursorSentinel = '‸'++-- Render markdown with username highlighting+renderRichText :: Text -> HighlightSet -> Maybe Int -> Seq RichTextBlock -> Widget a+renderRichText curUser hSet w =+ B.vBox . toList . fmap (blockToWidget curUser hSet w) . addBlankLines++-- Add blank lines only between adjacent elements of the same type, to+-- save space+addBlankLines :: Seq RichTextBlock -> Seq RichTextBlock+addBlankLines = go' . viewl+ where go' EmptyL = S.empty+ go' (x :< xs) = go x (viewl xs)+ go a@Para {} (b@Para {} :< rs) =+ a <| blank <| go b (viewl rs)+ go a@Header {} (b@Header {} :< rs) =+ a <| blank <| go b (viewl rs)+ go a@Blockquote {} (b@Blockquote {} :< rs) =+ a <| blank <| go b (viewl rs)+ go a@List {} (b@List {} :< rs) =+ a <| blank <| go b (viewl rs)+ go a@CodeBlock {} (b@CodeBlock {} :< rs) =+ a <| blank <| go b (viewl rs)+ go a@HTMLBlock {} (b@HTMLBlock {} :< rs) =+ a <| blank <| go b (viewl rs)+ go x (y :< rs) = x <| go y (viewl rs)+ go x (EmptyL) = S.singleton x+ blank = Para (S.singleton (Element Normal ESpace))++-- Render text to markdown without username highlighting+renderText :: Text -> Widget a+renderText txt = renderText' "" emptyHSet txt++renderText' :: Text -> HighlightSet -> Text -> Widget a+renderText' curUser hSet t = renderRichText curUser hSet Nothing rtBs+ where rtBs = parseMarkdown t++vBox :: F.Foldable f => f (Widget a) -> Widget a+vBox = B.vBox . toList++hBox :: F.Foldable f => f (Widget a) -> Widget a+hBox = B.hBox . toList++header :: Int -> Widget a+header n = B.txt (T.replicate n "#")++maybeHLimit :: Maybe Int -> Widget a -> Widget a+maybeHLimit Nothing w = w+maybeHLimit (Just i) w = hLimit i w++blockToWidget :: Text -> HighlightSet -> Maybe Int -> RichTextBlock -> Widget a+blockToWidget curUser hSet w (Para is) =+ toElementChunk curUser w is hSet+blockToWidget curUser hSet w (Header n is) =+ B.withDefAttr clientHeaderAttr $+ hBox [B.padRight (B.Pad 1) $ header n, toElementChunk curUser (subtract 1 <$> w) is hSet]+blockToWidget curUser hSet w (Blockquote is) =+ maybeHLimit w $+ addQuoting (vBox $ fmap (blockToWidget curUser hSet w) is)+blockToWidget curUser hSet w (List _ l bs) =+ maybeHLimit w $+ blocksToList curUser l w bs hSet+blockToWidget _ hSet _ (CodeBlock ci tx) =+ let f = maybe rawCodeBlockToWidget (codeBlockToWidget (hSyntaxMap hSet)) mSyntax+ mSyntax = do+ lang <- codeBlockLanguage ci+ Sky.lookupSyntax lang (hSyntaxMap hSet)+ in f tx+blockToWidget _ _ w (HTMLBlock t) =+ maybeHLimit w $+ textWithCursor t+blockToWidget _ _ w (HRule) =+ maybeHLimit w $+ B.vLimit 1 (B.fill '*')++quoteChar :: Char+quoteChar = '>'++addQuoting :: B.Widget n -> B.Widget n+addQuoting w =+ B.Widget B.Fixed (B.vSize w) $ do+ ctx <- B.getContext+ childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w++ let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height+ height = V.imageHeight $ childResult^.B.imageL++ B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder+ , B.Widget B.Fixed B.Fixed $ return childResult+ ]++codeBlockToWidget :: Sky.SyntaxMap -> Sky.Syntax -> Text -> Widget a+codeBlockToWidget syntaxMap syntax tx =+ let result = Sky.tokenize cfg syntax tx+ cfg = Sky.TokenizerConfig syntaxMap False+ in case result of+ Left _ -> rawCodeBlockToWidget tx+ Right tokLines ->+ let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)+ in (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=>+ (padding <+> BS.renderRawSource textWithCursor tokLines)++rawCodeBlockToWidget :: Text -> Widget a+rawCodeBlockToWidget tx =+ B.withDefAttr codeAttr $+ let padding = B.padLeftRight 1 (B.vLimit (length theLines) B.vBorder)+ theLines = expandEmpty <$> T.lines tx+ expandEmpty "" = " "+ expandEmpty s = s+ in padding <+> (B.vBox $ textWithCursor <$> theLines)++toElementChunk :: Text -> Maybe Int -> Seq Element -> HighlightSet -> Widget a+toElementChunk curUser w es hSet = B.Widget B.Fixed B.Fixed $ do+ ctx <- B.getContext+ let width = fromMaybe (ctx^.B.availWidthL) w+ ws = fmap (renderElementSeq curUser) (wrapLine width hSet es)+ B.render (vBox (fmap hBox ws))++blocksToList :: Text -> ListType -> Maybe Int -> Seq (Seq RichTextBlock) -> HighlightSet -> Widget a+blocksToList curUser lt w bs hSet = vBox+ [ B.txt i <+> (vBox (fmap (blockToWidget curUser hSet w) b))+ | b <- F.toList bs+ | i <- is ]+ where is = case lt of+ Bullet _ -> repeat ("• ")+ Numbered Period s ->+ [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]+ Numbered Paren s ->+ [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ]++data SplitState = SplitState+ { splitChunks :: Seq (Seq Element)+ , splitCurrCol :: Int+ }++wrapLine :: Int -> HighlightSet -> Seq Element -> Seq (Seq Element)+wrapLine maxCols hSet = splitChunks . go (SplitState (S.singleton S.empty) 0)+ where go st (viewl-> e :< es) = go st' es+ where+ HighlightSet { hUserSet = uSet, hChannelSet = cSet } = hSet++ -- Right before we check the width of the token, we see+ -- if the token is a user or channel reference. If so, we+ -- check if it is valid. If it is valid, we leave it in+ -- place; otherwise we translate it into an ordinary text+ -- element so that it does not render highlighted as a+ -- valid user or channel reference.+ newElement = e { eData = newEData }+ newEData = case eData e of+ EUser u ->+ if u `Set.member` uSet+ then EUser u+ else EText $ userSigil <> u+ EChannel c ->+ if c `Set.member` cSet+ then EChannel c+ else EText $ normalChannelSigil <> c+ d -> d++ addHyperlink url el = setElementStyle (Hyperlink url (eStyle el)) el++ st' =+ case newEData of+ EHyperlink url (Just labelEs) ->+ go st $ addHyperlink url <$> labelEs+ EImage url (Just labelEs) ->+ go st $ addHyperlink url <$> labelEs+ _ ->+ if | newEData == ESoftBreak || newEData == ELineBreak ->+ st { splitChunks = splitChunks st |> S.empty+ , splitCurrCol = 0+ }+ | available >= eWidth ->+ st { splitChunks = addElement newElement (splitChunks st)+ , splitCurrCol = splitCurrCol st + eWidth+ }+ | newEData == ESpace ->+ st { splitChunks = splitChunks st |> S.empty+ , splitCurrCol = 0+ }+ | otherwise ->+ st { splitChunks = splitChunks st |> S.singleton newElement+ , splitCurrCol = eWidth+ }+ available = maxCols - splitCurrCol st+ eWidth = elementWidth newElement+ addElement x (viewr-> ls :> l) = ( ls |> (l |> x))+ addElement _ _ = error "[unreachable]"+ go st _ = st++renderElementSeq :: Text -> Seq Element -> Seq (Widget a)+renderElementSeq curUser es = renderElement curUser <$> es++renderElement :: Text -> Element -> Widget a+renderElement curUser e = addStyle sty widget+ where+ sty = eStyle e+ dat = eData e+ addStyle s = case s of+ Normal -> id+ Emph -> B.withDefAttr clientEmphAttr+ Strong -> B.withDefAttr clientStrongAttr+ Code -> B.withDefAttr codeAttr+ Hyperlink (URL url) innerSty ->+ B.hyperlink url . B.withDefAttr urlAttr . addStyle innerSty+ rawText = B.txt . removeCursor+ widget = case dat of+ -- Cursor sentinels get parsed as individual text nodes by+ -- Cheapskate, meaning that we get a text node with exactly+ -- one character in it. That's why we compare accordingly+ -- above. In addition, since that character has no width, we+ -- have to replace it with something that has a size (such+ -- as a space) to get Brick's visibility logic to scroll the+ -- viewport to get it into view.+ EText t -> if t == T.singleton (cursorSentinel)+ then B.visible $ B.txt " "+ else rawText t++ ESpace -> B.txt " "+ ERawHtml t -> rawText t+ EEditSentinel recent -> let attr = if recent+ then editedRecentlyMarkingAttr+ else editedMarkingAttr+ in B.withDefAttr attr $ B.txt editMarking+ EUser u -> colorUsername curUser u $ userSigil <> u+ EChannel c -> B.withDefAttr channelNameAttr $+ B.txt $ normalChannelSigil <> c+ EHyperlink (URL url) Nothing -> rawText url+ EImage (URL url) Nothing -> rawText url+ EEmoji em -> B.withDefAttr emojiAttr $+ B.txt $ ":" <> em <> ":"++ -- Hyperlink and image nodes with labels should not appear+ -- at this point because line-wrapping should break them up+ -- into normal text node sequences with hyperlink styles+ -- attached.+ EHyperlink {} -> rawText "(Report renderElement bug #1)"+ EImage {} -> rawText "(Report renderElement bug #2)"++ -- Line breaks should never need to get rendered since the+ -- line-wrapping algorithm removes them.+ ESoftBreak -> B.emptyWidget+ ELineBreak -> B.emptyWidget++textWithCursor :: Text -> Widget a+textWithCursor t+ | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t+ | otherwise = B.txt t++removeCursor :: Text -> Text+removeCursor = T.filter (/= cursorSentinel)++editMarking :: Text+editMarking = "(edited)"++elementWidth :: Element -> Int+elementWidth e =+ case eData e of+ EText t -> B.textWidth t+ ERawHtml t -> B.textWidth t+ EUser t -> T.length userSigil + B.textWidth t+ EChannel t -> T.length normalChannelSigil + B.textWidth t+ EEditSentinel _ -> B.textWidth editMarking+ EImage (URL url) Nothing -> B.textWidth url+ EImage _ (Just is) -> sum $ elementWidth <$> is+ EHyperlink (URL url) Nothing -> B.textWidth url+ EHyperlink _ (Just is) -> sum $ elementWidth <$> is+ EEmoji t -> B.textWidth t + 2+ ESpace -> 1+ ELineBreak -> 0+ ESoftBreak -> 0
src/Draw/ShowHelp.hs view
@@ -28,6 +28,7 @@ import Events.Keybindings import Events.Main import Events.MessageSelect+import Events.ThemeListOverlay import Events.PostListOverlay import Events.ShowHelp import Events.UrlSelect@@ -38,7 +39,7 @@ import Events.TabbedWindow import Windows.ViewMessage import HelpTopics ( helpTopics )-import Markdown ( renderText )+import Draw.RichText ( renderText ) import Options ( mhVersion ) import State.Editing ( editingKeyHandlers ) import Themes@@ -53,6 +54,9 @@ helpTopicDraw :: HelpTopic -> ChatState -> Widget Name helpTopicDraw topic st =+ overrideAttr codeAttr helpEmphAttr $+ hCenter $+ hLimit helpContentWidth $ case helpTopicScreen topic of MainHelp -> mainHelp (configUserKeys (st^.csResources.crConfiguration)) ScriptHelp -> scriptHelp@@ -61,23 +65,23 @@ KeybindingHelp -> keybindingHelp (configUserKeys (st^.csResources.crConfiguration)) mainHelp :: KeyConfig -> Widget Name-mainHelp kc = commandHelp+mainHelp kc = summary where- commandHelp = vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ str mhVersion- , hCenter $ withDefAttr helpEmphAttr $ str mmApiVersion- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Help Topics"- , drawHelpTopics- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands"- , mkCommandHelpText- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybindings"- ] <>- (mkKeybindingHelp kc <$> keybindSections)+ summary = vBox entries+ entries = [ heading $ T.pack mhVersion+ , headingNoPad $ T.pack mmApiVersion+ , heading "Help Topics"+ , drawHelpTopics+ , heading "Commands"+ , padTop (Pad 1) mkCommandHelpText+ , heading "Keybindings"+ ] <>+ (mkKeybindingHelp kc <$> keybindSections) mkCommandHelpText :: Widget Name mkCommandHelpText =- let commandNameWidth = 4 + (maximum $ T.length <$> fst <$> commandHelpInfo)- in hCenter $- vBox [ (withDefAttr helpEmphAttr $ txt $ padTo commandNameWidth info) <+> renderText desc+ let commandNameWidth = 2 + (maximum $ T.length <$> fst <$> commandHelpInfo)+ in vBox [ (emph $ txt $ padTo commandNameWidth info) <+> renderText desc | (info, desc) <- commandHelpInfo ] @@ -116,23 +120,23 @@ drawHelpTopics = let allHelpTopics = drawTopic <$> helpTopics topicNameWidth = 4 + (maximum $ T.length <$> helpTopicName <$> helpTopics)- drawTopic t = (withDefAttr helpEmphAttr $ txt (padTo topicNameWidth $ helpTopicName t)) <+>+ drawTopic t = (emph $ txt (padTo topicNameWidth $ helpTopicName t)) <+> txt (helpTopicDescription t)- in (padBottom (Pad 1) $- hCenter $ renderText "Learn more about these topics with `/help <topic>`:") <=>- (hCenter $ vBox allHelpTopics)+ in vBox $ (padBottom (Pad 1) $+ para "Learn more about these topics with `/help <topic>`:")+ : allHelpTopics +helpContentWidth :: Int+helpContentWidth = 72+ scriptHelp :: Widget Name-scriptHelp = vBox- [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Scripts"- , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox scriptHelpText- ]- where scriptHelpText = map (padTop (Pad 1) . renderText . mconcat)+scriptHelp = heading "Using Scripts" <=> vBox scriptHelpText+ where scriptHelpText = map paraL [ [ "Matterhorn has a special feature that allows you to use " , "prewritten shell scripts to preprocess messages. " , "For example, this can allow you to run various filters over " , "your written text, do certain kinds of automated formatting, "- , "or just automatically cowsay-ify a message.\n" ]+ , "or just automatically cowsay-ify a message." ] , [ "These scripts can be any kind of executable file, " , "as long as the file lives in " , "*~/.config/matterhorn/scripts* (unless you've explicitly "@@ -144,24 +148,24 @@ , "that appeared on *stderr* is discarded; if it instead exits with " , "a failing exit code, your message is *not* sent, and you are " , "presented with whatever was printed on stderr as a "- , "local error message.\n" ]- , [ "To run a script, simply type\n" ]- , [ "> *> /sh [script-name] [my-message]*\n" ]+ , "local error message." ]+ , [ "To run a script, simply type" ]+ , [ "> *> /sh [script-name] [my-message]*" ] , [ "And the script named *[script-name]* will be invoked with " , "the text of *[my-message]*. If the script does not exist, " , "or if it exists but is not marked as executable, you'll be "- , "presented with an appropriate error message.\n" ]+ , "presented with an appropriate error message." ] , [ "For example, if you want to use a basic script to " , "automatically ROT13 your message, you can write a shell "- , "script using the standard Unix *tr* utility, like this:\n" ]- , [ "> *#!/bin/bash -e*\n"- , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*\n\n" ]+ , "script using the standard Unix *tr* utility, like this:" ]+ , [ "> *#!/bin/bash -e*"+ , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*" ] , [ "Move this script to *~/.config/matterhorn/scripts/rot13* "- , "and be sure it's executable with\n" ]- , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*\n\n" ]+ , "and be sure it's executable with" ]+ , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*" ] , [ "after which you can send ROT13 messages with the " , "Matterhorn command " ]- , [ "> *> /sh rot13 Hello, world!*\n" ]+ , [ "> *> /sh rot13 Hello, world!*" ] ] keybindingMarkdownTable :: KeyConfig -> Text@@ -186,26 +190,25 @@ "\n" <> (T.replicate (T.length n) "=") keybindingHelp :: KeyConfig -> Widget Name-keybindingHelp kc = hCenter $ hLimit 100 $ vBox $- [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Configurable Keybindings"- , padTop (Pad 1) $ hCenter $ vBox keybindingHelpText+keybindingHelp kc = vBox $+ [ heading "Configurable Keybindings"+ , padBottom (Pad 1) $ vBox keybindingHelpText ] ++ keybindSectionWidgets ++- [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybinding Syntax"- , padTop (Pad 1) $ hCenter $ vBox validKeys+ [ headingNoPad "Keybinding Syntax"+ , vBox validKeys ] where keybindSectionWidgets = sectionWidget <$> keybindSections- sectionWidget = mkKeybindEventSectionHelp kc keybindEventHelpWidget vBox mkSectionHeading- mkSectionHeading = hCenter . padTop (Pad 1) . withDefAttr helpEmphAttr . txt+ sectionWidget = mkKeybindEventSectionHelp kc keybindEventHelpWidget vBox headingNoPad - keybindingHelpText = map (padTop (Pad 1) . renderText . mconcat)+ keybindingHelpText = map paraL [ [ "Many of the keybindings used in Matterhorn can be " , "modified from within Matterhorn's **config.ini** file. " , "To do this, include a section called **[KEYBINDINGS]** " , "in your config file and use the event names listed below as " , "keys and the desired key sequence as values. " , "See the end of this page for documentation on the valid "- , "syntax for key sequences.\n"+ , "syntax for key sequences." ] , [ "For example, by default, the keybinding to move to the next " , "channel in the public channel list is **"@@ -215,34 +218,34 @@ , prevChanBinding , "**. You might want to remap these " , "to other keys: say, **C-j** and **C-k**. We can do this with the following "- , "configuration snippet:\n"+ , "configuration snippet:" ] , [ "```ini\n" , "[KEYBINDINGS]\n" , "focus-next-channel = C-j\n" , "focus-prev-channel = C-k\n"- , "```\n"+ , "```" ] , [ "You can remap a command to more than one key sequence, in which " , "case any one of the key sequences provided can be used to invoke " , "the relevant command. To do this, provide the desired bindings as " , "a comma-separated list. Additionally, some key combinations are " , "used in multiple modes (such as URL select or help viewing) and "- , "therefore share the same name, such as **cancel** or **scroll-up**.\n"+ , "therefore share the same name, such as **cancel** or **scroll-up**." ] , [ "Additionally, some keys simply cannot be remapped, mostly in the " , "case of editing keybindings. If you feel that a particular key " , "event should be rebindable and isn't, then please feel free to "- , "let us know by posting an issue in the Matterhorn issue tracker.\n"+ , "let us know by posting an issue in the Matterhorn issue tracker." ] , [ "It is also possible to entirely unbind a key event by setting its " , "key to **unbound**, thus avoiding conflicts between default bindings "- , "and new ones:\n"+ , "and new ones:" ] , [ "```ini\n" , "[KEYBINDINGS]\n" , "focus-next-channel = unbound\n"- , "```\n"+ , "```" ] , [ "The rebindable key events, along with their **current** " , "values, are as follows:"@@ -250,7 +253,7 @@ ] nextChanBinding = ppBinding (getFirstDefaultBinding NextChannelEvent) prevChanBinding = ppBinding (getFirstDefaultBinding PrevChannelEvent)- validKeys = map (padTop (Pad 1) . renderText . mconcat)+ validKeys = map paraL [ [ "The syntax used for key sequences consists of zero or more " , "single-character modifier characters followed by a keystroke, " , "all separated by dashes. The available modifier keys are "@@ -282,12 +285,25 @@ ] ] +emph :: Widget a -> Widget a+emph = withDefAttr helpEmphAttr+ para :: Text -> Widget a-para t = padTop (Pad 1) $ hCenter (hLimit 72 $ padRight Max $ renderText t)+para t = padTop (Pad 1) $ renderText t +paraL :: [Text] -> Widget a+paraL = para . mconcat++heading :: Text -> Widget a+heading = padTop (Pad 1) . headingNoPad++headingNoPad :: Text -> Widget a+headingNoPad t = hCenter $ emph $ renderText t+ syntaxHighlightHelp :: [FilePath] -> Widget a-syntaxHighlightHelp dirs = overrideAttr codeAttr helpEmphAttr $ vBox- [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Syntax Highlighting"+syntaxHighlightHelp dirs = vBox+ [ heading "Syntax Highlighting"+ , para $ "Matterhorn supports syntax highlighting in Markdown code blocks when the " <> "name of the code block language follows the block opening sytnax:" , para $ "```<language>"@@ -307,26 +323,30 @@ ] themeHelp :: Widget a-themeHelp = overrideAttr codeAttr helpEmphAttr $ vBox- [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Themes"- , padTop (Pad 1) $ hCenter $ renderText "Matterhorn provides these built-in color themes:"- , padTop (Pad 1) $ vBox $ hCenter <$> withDefAttr helpEmphAttr <$>+themeHelp = vBox+ [ heading "Using Themes"+ , para "Matterhorn provides these built-in color themes:"+ , padTop (Pad 1) $ vBox $ hCenter <$> emph <$> txt <$> internalThemeName <$> internalThemes- , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $+ , para $ "These themes can be selected with the */theme* command. To automatically " <> "select a theme at startup, set the *theme* configuration file option to one " <> "of the themes listed above."- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Customizing the Theme"- , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $++ , heading "Customizing the Theme"+ , para $ "Theme customization is also supported. To customize the selected theme, " <> "create a theme customization file and set the `themeCustomizationFile` " <> "configuration option to the path to the customization file. If the path " <> "to the file is relative, Matterhorn will look for it in the same directory " <>- "as the Matterhorn configuration file.\n" <>- " \n" <>+ "as the Matterhorn configuration file."++ , para $ "Theme customization files are INI-style files that can customize any " <> "foreground color, background color, or style of any aspect of the " <>- "Matterhorn user interface. Here is an example:\n" <>+ "Matterhorn user interface. Here is an example:"++ , para $ "```\n" <> "[default]\n" <> "default.fg = blue\n" <>@@ -338,13 +358,17 @@ attrNameToConfig clientEmphAttr <> ".fg = cyan\n" <> attrNameToConfig clientEmphAttr <> ".style = [bold, underline]\n" <> attrNameToConfig listSelectedFocusedAttr <> ".fg = brightGreen\n" <>- "```\n" <>+ "```"++ , para $ "In the example above, the theme's default foreground and background colors " <> "are both customized to *blue* and *black*, respectively. The *default* section " <> "contains only customizations for the *default* attribute. All other customizations " <> "go in the *other* section. We can also set the style for attributes; we can either " <> "set just one style (as with the bold setting above) or multiple styles at once " <>- "(as in the bold/underline example).\n\n" <>+ "(as in the bold/underline example).\n"++ , para $ "Available colors are:\n" <> " * black\n" <> " * red\n" <>@@ -361,8 +385,9 @@ " * brightBlue\n" <> " * brightMagenta\n" <> " * brightCyan\n" <>- " * brightWhite\n" <>- " \n" <>+ " * brightWhite"++ , para $ "Available styles are:\n" <> " * standout\n" <> " * underline\n" <>@@ -370,39 +395,49 @@ " * reverseVideo\n" <> " * blink\n" <> " * dim\n" <>- " * bold\n" <>- " \n" <>+ " * bold\n"++ , para $+ "It is also possible to specify RGB values using HTML syntax: `#RRGGBB`. " <>+ "Bear in mind that such colors are clamped to the nearest 256-color palette " <>+ "entry, so it is not possible to get the exact color specified.\n\n" <> "In addition, a special value of *default* is possible for either color " <> "setting of an attribute. This value indicates that the attribute should " <> "use the terminal emulator's default foreground or background color of " <> "choice rather than a specific ANSI color."- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Username Highlighting"- , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $++ , heading "Username Highlighting"+ , para $ "Username colors are chosen by hashing each username and then using the hash " <> "to choose a color from a list of predefined username colors. If you would like " <> "to change the color in a given entry of this list, we provide the " <> "\"username.N\" attributes, where N is the index in the username color list."- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Theme Attributes"- , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $++ , heading "Theme Attributes"+ , para $ "This section lists all possible theme attributes for use in customization " <> "files along with a description of how each one is used in Matterhorn. Each " <> "option listed can be set in the *other* section of the customization file. " <>- "Each provides three customization settings:\n" <>+ "Each provides three customization settings:"++ , para $ " * *<option>.fg = <color>*\n" <> " * *<option>.bg = <color>*\n" <> " * *<option>.style = <style>* or *<option>.style = [<style>, ...]*\n" - , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $- let names = sort $- (\(n, msg) -> (attrNameToConfig n, msg)) <$>- (M.toList $ themeDescriptions themeDocs)- mkEntry (opt, msg) = "*" <> opt <> "*\n" <> msg <> "\n"- in T.concat $ mkEntry <$> names+ , let names = sort $+ (\(n, msg) -> (n, attrNameToConfig n, msg)) <$>+ (M.toList $ themeDescriptions themeDocs)+ mkEntry (n, opt, msg) =+ padTop (Pad 1) $+ vBox [ hBox [ withDefAttr clientEmphAttr $ txt opt+ , padLeft Max $ forceAttr n $ txt "(demo)"+ ]+ , txt msg+ ]+ in vBox $ mkEntry <$> names ] -attrNameToConfig :: AttrName -> Text-attrNameToConfig = T.pack . intercalate "." . attrNameComponents- keybindSections :: [(Text, [KeyEventHandler])] keybindSections = [ ("Global Keybindings", globalKeyHandlers)@@ -413,6 +448,7 @@ , ("Message Select Mode", messageSelectKeyHandlers) , ("Text Editing", editingKeyHandlers (csEditState.cedEditor)) , ("Flagged Messages", postListOverlayKeyHandlers)+ , ("Theme List Window", themeListOverlayKeyHandlers) , ("User Listings", userListOverlayKeyHandlers) , ("Channel Search Window", channelListOverlayKeyHandlers) , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeyHandlers)@@ -420,12 +456,13 @@ , ("Message Viewer: Message tab", viewMessageKeyHandlers) , ("Message Viewer: Reactions tab", viewMessageReactionsKeyHandlers) , ("Attachment List", attachmentListKeyHandlers)+ , ("Attachment File Browser", attachmentBrowseKeyHandlers) ] helpBox :: Name -> Widget Name -> Widget Name helpBox n helpText = withDefAttr helpAttr $- borderWithLabel (withDefAttr helpEmphAttr $ txt "Matterhorn Help") $+ borderWithLabel (emph $ txt "Matterhorn Help") $ viewport HelpViewport Vertical $ cached n helpText @@ -437,8 +474,8 @@ mkKeybindingHelp :: KeyConfig -> (Text, [KeyEventHandler]) -> Widget Name mkKeybindingHelp kc (sectionName, kbs) =- (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt sectionName) <=>- (hCenter $ vBox $ snd <$> sortWith fst results)+ (heading sectionName) <=>+ (padTop (Pad 1) $ hCenter $ vBox $ snd <$> sortWith fst results) where results = mkKeybindHelp kc <$> kbs @@ -459,7 +496,7 @@ | otherwise -> unbound in T.intercalate ", " bindings - rendering = (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $+ rendering = (emph $ txt $ padTo kbColumnWidth $ label) <+> txt " " <+> (hLimit kbDescColumnWidth $ padRight Max $ renderText $ ehDescription $ kehHandler h)@@ -480,10 +517,10 @@ let evText = T.intercalate ", " evs label = case evName of Left s -> txt $ "; " <> s- Right s -> withDefAttr helpEmphAttr $ txt s- in vBox [ txt (padTo 72 ("; " <> desc))+ Right s -> emph $ txt s+ in padBottom (Pad 1) $+ vBox [ txtWrap ("; " <> desc) , label <+> txt (" = " <> evText)- , str " " ] keybindEventHelpMarkdown :: (Either Text Text, Text, [Text]) -> Text
src/Draw/TabbedWindow.hs view
@@ -12,10 +12,10 @@ import Data.List ( intersperse ) import qualified Graphics.Vty as Vty +import Draw.Util ( renderKeybindingHelp ) import Types import Themes import Types.KeyEvents-import Events.Keybindings ( getFirstDefaultBinding ) -- | Render a tabbed window. drawTabbedWindow :: (Eq a, Show a)@@ -36,13 +36,10 @@ -- | Keybinding help to show at the bottom of a tabbed window. keybindingHelp :: Widget Name keybindingHelp =- let ppPair (label, evs) = hBox $ (intersperse (txt "/") $ ppEv <$> evs) <> [txt (":" <> label)]- ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (getFirstDefaultBinding ev))- pairs = [ ("Switch tabs", [SelectNextTabEvent, SelectPreviousTabEvent])- , ("Scroll", [ScrollUpEvent, ScrollDownEvent, ScrollLeftEvent, ScrollRightEvent])- , ("Close", [CancelEvent])+ let pairs = [ ("Switch tabs", [SelectNextTabEvent, SelectPreviousTabEvent])+ , ("Scroll", [ScrollUpEvent, ScrollDownEvent, ScrollLeftEvent, ScrollRightEvent, PageLeftEvent, PageRightEvent]) ]- in hBox $ intersperse (txt " ") $ ppPair <$> pairs+ in hBox $ intersperse (txt " ") $ (uncurry renderKeybindingHelp) <$> pairs -- | The scrollable tab bar to show at the top of a tabbed window. tabBar :: (Eq a, Show a)
+ src/Draw/ThemeListOverlay.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Draw.ThemeListOverlay+ ( drawThemeListOverlay+ )+where++import Prelude ()+import Prelude.MH++import Brick+import qualified Brick.Widgets.List as L+import Brick.Widgets.Border ( hBorder )+import Brick.Widgets.Center ( hCenter )++import Draw.Main+import Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )+import Themes+import Types+import Types.KeyEvents ( ppBinding )+import Events.Keybindings+++drawThemeListOverlay :: ChatState -> [Widget Name]+drawThemeListOverlay st =+ let overlay = drawListOverlay (st^.csThemeListOverlay)+ (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 (getFirstDefaultBinding ActivateListItemEvent)+ close = emph $ txt $ ppBinding (getFirstDefaultBinding CancelEvent)+ emph = withDefAttr clientEmphAttr+ in joinBorders overlay : drawMain True st++renderInternalTheme :: Bool -> InternalTheme -> Widget Name+renderInternalTheme foc it =+ (if foc then forceAttr L.listSelectedFocusedAttr else id) $+ (padRight Max $+ withDefAttr clientEmphAttr $+ txt $ internalThemeName it) <=>+ (vLimit 2 $+ (padLeft (Pad 2) $ txtWrap $ internalThemeDesc it) <=> fill ' ')
src/Draw/URLList.hs view
@@ -15,9 +15,10 @@ import Draw.Messages import Draw.Util-import Markdown+import Draw.RichText import Themes import Types+import Types.RichText ( unURL ) renderUrlList :: ChatState -> Widget Name@@ -34,20 +35,23 @@ urls = st^.csUrlList + me = myUsername st+ renderItem sel link = let time = link^.linkTime in attr sel $ vLimit 2 $ (vLimit 1 $- hBox [ let u = maybe "" id (link^.linkUser.to (nameForUserRef st)) in colorUsername (myUsername st) u u- , if link^.linkName == link^.linkURL- then emptyWidget- else (txt ": " <+> (renderText $ link^.linkName))+ hBox [ let u = maybe "<server>" id (link^.linkUser.to (nameForUserRef st))+ in colorUsername me u u+ , case link^.linkLabel of+ Nothing -> emptyWidget+ Just label -> txt ": " <+> hBox (F.toList $ renderElementSeq me label) , fill ' ' , renderDate st $ withServerTime time , str " " , renderTime st $ withServerTime time ] ) <=>- (vLimit 1 (renderText $ link^.linkURL))+ (vLimit 1 (renderText $ unURL $ link^.linkURL)) - attr True = forceAttr "urlListSelectedAttr"+ attr True = forceAttr urlListSelectedAttr attr False = id
src/Draw/UserListOverlay.hs view
@@ -16,7 +16,7 @@ import Draw.Main import Draw.Util ( userSigilFromInfo )-import Draw.ListOverlay ( drawListOverlay )+import Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) ) import Themes import Types @@ -26,6 +26,9 @@ let overlay = drawListOverlay (st^.csUserListOverlay) userSearchScopeHeader userSearchScopeNoResults userSearchScopePrompt (renderUser (myUsername st))+ Nothing+ OverlayCenter+ 80 in joinBorders overlay : drawMain False st userSearchScopePrompt :: UserSearchScope -> Widget Name
src/Draw/Util.hs view
@@ -2,6 +2,7 @@ ( withBrackets , renderTime , renderDate+ , renderKeybindingHelp , insertDateMarkers , getDateFormat , mkChannelName@@ -14,14 +15,18 @@ import Prelude.MH import Brick+import Data.List ( intersperse ) import qualified Data.Set as Set import qualified Data.Text as T import Lens.Micro.Platform ( to ) import Network.Mattermost.Types +import Constants ( userSigil, normalChannelSigil ) import Themes import TimeUtils import Types+import Types.KeyEvents+import Events.Keybindings ( getFirstDefaultBinding ) defaultTimeFormat :: Text@@ -52,6 +57,11 @@ if T.null fmt then emptyWidget else withDefAttr timeAttr (txt $ localTimeText fmt $ asLocalTime tz t)++renderKeybindingHelp :: Text -> [KeyEvent] -> Widget Name+renderKeybindingHelp label evs =+ let ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (getFirstDefaultBinding ev))+ in hBox $ (intersperse (txt "/") $ ppEv <$> evs) <> [txt (":" <> label)] -- | Generates a local matterhorn-only client message that creates a -- date marker. The server date is converted to a local time (via
src/Events.hs view
@@ -22,6 +22,7 @@ import Network.Mattermost.WebSocket import Connection+import Constants ( userSigil, normalChannelSigil ) import HelpTopics import State.Channels import State.Common@@ -39,6 +40,7 @@ import Events.LeaveChannelConfirm import Events.Main import Events.MessageSelect+import Events.ThemeListOverlay import Events.PostListOverlay import Events.ShowHelp import Events.UrlSelect@@ -47,6 +49,7 @@ import Events.ReactionEmojiListOverlay import Events.TabbedWindow import Events.ManageAttachments+import Events.EditNotifyPrefs onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState)@@ -191,6 +194,7 @@ MessageSelect -> onEventMessageSelect e MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e DeleteChannelConfirm -> onEventDeleteChannelConfirm e+ ThemeListOverlay -> onEventThemeListOverlay e PostListOverlay _ -> onEventPostListOverlay e UserListOverlay -> onEventUserListOverlay e ChannelListOverlay -> onEventChannelListOverlay e@@ -198,6 +202,7 @@ ViewMessage -> void $ handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e ManageAttachments -> onEventManageAttachments e ManageAttachmentsBrowseFiles -> onEventManageAttachments e+ EditNotifyPrefs -> void $ onEventEditNotifyPrefs e globalKeybindings :: KeyConfig -> KeyHandlerMap globalKeybindings = mkKeybindings globalKeyHandlers@@ -335,6 +340,14 @@ | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId | otherwise -> return () + WMChannelMemberUpdated+ | Just channelMember <- wepChannelMember $ weData we ->+ when (channelMemberUserId channelMember == myId) $+ updateChannelNotifyProps+ (channelMemberChannelId channelMember)+ (channelMemberNotifyProps channelMember)+ | otherwise -> return ()+ -- We are pretty sure we should do something about these: WMAddedToTeam -> return () @@ -344,7 +357,6 @@ WMTeamDeleted -> return () WMUserUpdated -> return () WMLeaveTeam -> return ()- WMChannelMemberUpdated {} -> return () -- We deliberately ignore these events: WMChannelCreated -> return ()
+ src/Events/EditNotifyPrefs.hs view
@@ -0,0 +1,48 @@+module Events.EditNotifyPrefs+ ( onEventEditNotifyPrefs+ , editNotifyPrefsKeybindings+ , editNotifyPrefsKeyHandlers+ )+where++import Prelude ()+import Prelude.MH++import Brick+import Brick.Forms (handleFormEvent, formState)+import Data.Maybe (fromJust)+import qualified Graphics.Vty as V+import qualified Network.Mattermost.Endpoints as MM++import Lens.Micro.Platform (_Just, (.=), singular)++import Types+import Types.KeyEvents+import Events.Keybindings+import State.NotifyPrefs+import State.Async++onEventEditNotifyPrefs :: V.Event -> MH Bool+onEventEditNotifyPrefs =+ let fallback e = do+ form <- use (csNotifyPrefs.singular _Just)+ updatedForm <- mh $ handleFormEvent (VtyEvent e) form+ csNotifyPrefs .= Just updatedForm+ in handleKeyboardEvent editNotifyPrefsKeybindings fallback++editNotifyPrefsKeybindings :: KeyConfig -> KeyHandlerMap+editNotifyPrefsKeybindings = mkKeybindings editNotifyPrefsKeyHandlers++editNotifyPrefsKeyHandlers :: [KeyEventHandler]+editNotifyPrefsKeyHandlers =+ [ mkKb CancelEvent "Close channel notification preferences" exitEditNotifyPrefsMode+ , mkKb FormSubmitEvent "Save channel notification preferences" $ do+ st <- use id+ let form = fromJust $ st^.csNotifyPrefs+ cId = st^.csCurrentChannelId++ doAsyncChannelMM Preempt cId+ (\s _ -> MM.mmUpdateChannelNotifications cId (myUserId st) (formState form) s)+ (\_ _ -> Nothing)+ exitEditNotifyPrefsMode+ ]
src/Events/Keybindings.hs view
@@ -149,6 +149,7 @@ defaultBindings ev = let meta binding = binding { kbMods = Vty.MMeta : kbMods binding } ctrl binding = binding { kbMods = Vty.MCtrl : kbMods binding }+ shift binding = binding { kbMods = Vty.MShift : kbMods binding } kb k = Binding { kbMods = [], kbKey = k } key c = Binding { kbMods = [], kbKey = Vty.KChar c } fn n = Binding { kbMods = [], kbKey = Vty.KFun n }@@ -183,8 +184,11 @@ ScrollRightEvent -> [ kb Vty.KRight ] PageUpEvent -> [ kb Vty.KPageUp ] PageDownEvent -> [ kb Vty.KPageDown ]+ PageLeftEvent -> [ shift (kb Vty.KLeft) ]+ PageRightEvent -> [ shift (kb Vty.KRight) ] ScrollTopEvent -> [ kb Vty.KHome ] ScrollBottomEvent -> [ kb Vty.KEnd ]+ SelectOldestMessageEvent -> [ shift (kb Vty.KHome) ] SelectUpEvent -> [ key 'k', kb Vty.KUp ] SelectDownEvent -> [ key 'j', kb Vty.KDown ] ActivateListItemEvent -> [ kb Vty.KEnter ]@@ -220,6 +224,7 @@ EditorHomeEvent -> [ kb Vty.KHome ] EditorEndEvent -> [ kb Vty.KEnd ] EditorYankEvent -> [ ctrl (key 'y') ]+ FormSubmitEvent -> [ kb Vty.KEnter ] -- | Given a configuration, we want to check it for internal consistency -- (i.e. that a given keybinding isn't associated with multiple events
src/Events/Main.hs view
@@ -49,7 +49,7 @@ , mkKb InvokeEditorEvent- "Invoke *$EDITOR* to edit the current message"+ "Invoke `$EDITOR` to edit the current message" invokeExternalEditor , mkKb@@ -95,7 +95,7 @@ , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do beginMessageSelect - , mkKb ScrollTopEvent "Scroll to top of channel message list" $ do+ , mkKb SelectOldestMessageEvent "Scroll to top of channel message list" $ do beginMessageSelect messageSelectFirst
src/Events/ManageAttachments.hs view
@@ -3,6 +3,7 @@ module Events.ManageAttachments ( onEventManageAttachments , attachmentListKeybindings+ , attachmentBrowseKeyHandlers , attachmentBrowseKeybindings , attachmentListKeyHandlers )@@ -12,7 +13,6 @@ import Prelude.MH import qualified Control.Exception as E-import Control.Monad ( void ) import qualified Brick.Widgets.FileBrowser as FB import qualified Brick.Widgets.List as L import qualified Data.ByteString as BS@@ -61,7 +61,10 @@ ] attachmentBrowseKeybindings :: KeyConfig -> KeyHandlerMap-attachmentBrowseKeybindings = mkKeybindings+attachmentBrowseKeybindings = mkKeybindings attachmentBrowseKeyHandlers++attachmentBrowseKeyHandlers :: [KeyEventHandler]+attachmentBrowseKeyHandlers = [ mkKb CancelEvent "Cancel attachment file browse" cancelAttachmentBrowse , mkKb AttachmentOpenEvent "Open the selected file using the URL open command"
+ src/Events/ThemeListOverlay.hs view
@@ -0,0 +1,30 @@+module Events.ThemeListOverlay where++import Prelude ()+import Prelude.MH++import qualified Graphics.Vty as Vty++import Events.Keybindings+import State.ThemeListOverlay+import State.ListOverlay+import Types+++onEventThemeListOverlay :: Vty.Event -> MH ()+onEventThemeListOverlay =+ void . onEventListOverlay csThemeListOverlay themeListOverlayKeybindings++-- | The keybindings we want to use while viewing a user list overlay+themeListOverlayKeybindings :: KeyConfig -> KeyHandlerMap+themeListOverlayKeybindings = mkKeybindings themeListOverlayKeyHandlers++themeListOverlayKeyHandlers :: [KeyEventHandler]+themeListOverlayKeyHandlers =+ [ mkKb CancelEvent "Close the theme list" (exitListOverlay csThemeListOverlay)+ , mkKb SearchSelectUpEvent "Select the previous theme" themeListSelectUp+ , mkKb SearchSelectDownEvent "Select the next theme" themeListSelectDown+ , mkKb PageDownEvent "Page down in the theme list" themeListPageDown+ , mkKb PageUpEvent "Page up in the theme list" themeListPageUp+ , mkKb ActivateListItemEvent "Switch to the selected color theme" (listOverlayActivateCurrent csThemeListOverlay)+ ]
src/Login.hs view
@@ -81,7 +81,7 @@ import Network.Mattermost.Exceptions ( LoginFailureException(..) ) import Network.Mattermost.Endpoints ( mmGetUser, mmGetLimitedClientConfiguration, mmLogin ) -import Markdown+import Draw.RichText import Themes ( clientEmphAttr ) import Types ( ConnectionInfo(..) , ciPassword, ciUsername, ciHostname, ciUrlPath@@ -223,28 +223,35 @@ --- | Searches prefixes of the given URL to determine Mattermost API URL path and team name+-- | Searches prefixes of the given URL to determine Mattermost API URL+-- path and team name findConnectionData :: ConnectionInfo -> IO (Either SomeException (ConnectionData, Maybe Text)) findConnectionData connInfo = startSearch- where components = filter (not . T.null) (T.split ('/'==) (connInfo^.ciUrlPath)) - -- the candidates list is never empty because inits never returns an empty list+ -- the candidates list is never empty because inits never returns an+ -- empty list primary:alternatives = reverse- [ (T.intercalate "/" l, listToMaybe r) | (l,r) <- zip (inits components) (tails components) ]+ [ (T.intercalate "/" l, listToMaybe r)+ | (l,r) <- zip (inits components) (tails components)+ ] - tryCandidate :: (Text, Maybe Text) -> IO (Either SomeException (ConnectionData, Maybe Text))+ tryCandidate :: (Text, Maybe Text)+ -> IO (Either SomeException (ConnectionData, Maybe Text)) tryCandidate (path, team) =- do cd <- initConnectionData (connInfo^.ciHostname) (fromIntegral (connInfo^.ciPort)) path (connInfo^.ciType) poolCfg+ do cd <- initConnectionData (connInfo^.ciHostname)+ (fromIntegral (connInfo^.ciPort))+ path (connInfo^.ciType) poolCfg res <- try (mmGetLimitedClientConfiguration cd) pure $! case res of Left e -> Left e Right{} -> Right (cd, team) - -- This code prefers to report the error from the URL corresponding to what the user- -- actually provided. Errors from derived URLs are lost in favor of this first error.+ -- This code prefers to report the error from the URL corresponding+ -- to what the user actually provided. Errors from derived URLs are+ -- lost in favor of this first error. startSearch = do res1 <- tryCandidate primary case res1 of
− src/Markdown.hs
@@ -1,634 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}--module Markdown- ( MessageData(..)- , renderMessage- , renderText- , renderText'- , cursorSentinel- , addEllipsis- , findVerbatimChunk- )-where--import Prelude ()-import Prelude.MH--import Brick ( (<+>), Widget, textWidth, hLimit, imageL- , raw, render, Size(..), Widget(..)- )-import qualified Brick as B-import qualified Brick.Widgets.Border as B-import qualified Brick.Widgets.Skylighting as BS-import qualified Cheapskate as C-import Cheapskate.Types ( Block- , Blocks- , Inlines- , ListType- )-import qualified Data.Foldable as F-import qualified Data.Map.Strict as Map-import Data.Monoid (First(..))-import qualified Data.Sequence as Seq-import Data.Sequence ( ViewL(..)- , ViewR(..)- , (<|)- , (|>)- , viewl- , viewr)-import qualified Data.Sequence as S-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Graphics.Vty as V-import qualified Skylighting.Core as Sky--import Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )-import Network.Mattermost.Types ( ServerTime(..) )--import Themes-import Types ( Name, HighlightSet(..), userSigil, normalChannelSigil )-import Types.Messages-import Types.Posts-import Types.UserNames ( isNameFragment, takeWhileNameFragment )---emptyHSet :: HighlightSet-emptyHSet = HighlightSet Set.empty Set.empty mempty--omittedUsernameType :: MessageType -> Bool-omittedUsernameType = \case- CP Join -> True- CP Leave -> True- CP TopicChange -> True- _ -> False----- The special string we use to indicate the placement of a styled--- indication that a message has been edited.-editMarkingSentinel :: Text-editMarkingSentinel = "#__mh_edit"---- The special string we use to indicate the placement of a styled--- indication that a message has been edited recently.-editRecentlyMarkingSentinel :: Text-editRecentlyMarkingSentinel = "#__mh_edit_r"---- The actual user-facing text that we render in place of the edit--- marking sentinel.-editMarking :: Text-editMarking = "(edited)"---- Add the edit sentinel to the end of the last block in the sequence.--- If the last block is a paragraph, append it to that paragraph.--- Otherwise, append a new block so it appears beneath the last--- block-level element.-addEditSentinel :: Text -> Blocks -> Blocks-addEditSentinel s bs =- case viewr bs of- EmptyR -> bs- (rest :> b) -> rest <> appendEditSentinel s b--appendEditSentinel :: Text -> Block -> Blocks-appendEditSentinel sentinel b =- let s = C.Para (S.singleton m)- m = C.Str sentinel- in case b of- C.Para is -> S.singleton $ C.Para (is |> C.Str " " |> m)- _ -> S.fromList [b, s]---- | A bundled structure that includes all the information necessary--- to render a given message-data MessageData =- MessageData { mdEditThreshold :: Maybe ServerTime- -- ^ If specified, any messages edited before this point- -- in time are not indicated as edited.- , mdShowOlderEdits :: Bool- -- ^ Indicates whether "edited" markers should be shown- -- for old messages (i.e., ignore the mdEditThreshold- -- value).- , mdShowReactions :: Bool- -- ^ Whether to render reactions.- , mdMessage :: Message- -- ^ The message to render.- , mdUserName :: Maybe Text- -- ^ The username of the message's author, if any. This- -- is passed here rather than obtaining from the message- -- because we need to do lookups in the ChatState to- -- compute this, and we don't pass the ChatState into- -- renderMessage.- , mdParentMessage :: Maybe Message- -- ^ The parent message of this message, if any.- , mdParentUserName :: Maybe Text- -- ^ The author of the parent message, if any.- , mdThreadState :: ThreadState- -- ^ The thread state of this message.- , mdRenderReplyParent :: Bool- -- ^ Whether to render the parent message.- , mdHighlightSet :: HighlightSet- -- ^ The highlight set to use to highlight usernames,- -- channel names, etc.- , mdIndentBlocks :: Bool- -- ^ Whether to indent the message underneath the- -- author's name (True) or just display it to the right- -- of the author's name (False).- , mdMessageWidthLimit :: Maybe Int- -- ^ A width override to use to wrap non-code blocks. If- -- unspecified, all blocks in the message will be- -- wrapped and truncated at the width specified by the- -- rendering context. If specified, all non-code blocks- -- will be wrapped at this width and code blocks will be- -- rendered using the context's width.- , mdMyUsername :: Text- -- ^ The username of the user running Matterhorn.- }---- | renderMessage performs markdown rendering of the specified message.-renderMessage :: MessageData -> Widget Name-renderMessage md@MessageData { mdMessage = msg, .. } =- let msgUsr = case mdUserName of- Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u- Nothing -> Nothing- botElem = if isBotMessage msg then B.txt "[BOT]" else B.emptyWidget- nameElems = case msgUsr of- Just un- | isEmote msg ->- [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN]" else ""- , B.txt $ (if msg^.mFlagged then "[!] " else "") <> "*"- , colorUsername mdMyUsername un un- , botElem- , B.txt " "- ]- | otherwise ->- [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN] " else ""- , colorUsername mdMyUsername un un- , botElem- , B.txt $ (if msg^.mFlagged then "[!]" else "") <> ": "- ]- Nothing -> []-- -- Use the editing threshold to determine whether to append an- -- editing indication to this message.- maybeAugment bs = case msg^.mOriginalPost of- Nothing -> bs- Just p ->- if p^.postEditAtL > p^.postCreateAtL- then case mdEditThreshold of- Just cutoff | p^.postEditAtL >= cutoff ->- addEditSentinel editRecentlyMarkingSentinel bs- _ -> if mdShowOlderEdits- then addEditSentinel editMarkingSentinel bs- else bs- else bs-- augmentedText = maybeAugment $ msg^.mText- msgWidget =- vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText :- catMaybes [msgAtch, msgReac]- replyIndent = B.Widget B.Fixed B.Fixed $ do- ctx <- B.getContext- -- NB: The amount subtracted here must be the total padding- -- added below (pad 1 + vBorder)- w <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) msgWidget- B.render $ B.vLimit (V.imageHeight $ w^.B.imageL) $- B.padRight (B.Pad 1) B.vBorder B.<+> (B.Widget B.Fixed B.Fixed $ return w)- msgAtch = if Seq.null (msg^.mAttachments)- then Nothing- else Just $ B.withDefAttr clientMessageAttr $ vBox- [ B.txt (" [attached: `" <> a^.attachmentName <> "`]")- | a <- toList (msg^.mAttachments)- ]- msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions)- then Nothing- else let renderR e us =- let n = Set.size us- in if | n == 1 -> " [" <> e <> "]"- | n > 1 -> " [" <> e <> " " <> T.pack (show n) <> "]"- | otherwise -> ""- reactionMsg = Map.foldMapWithKey renderR (msg^.mReactions)- in Just $ B.withDefAttr emojiAttr $ B.txt (" " <> reactionMsg)- withParent p =- case mdThreadState of- NoThread -> msgWidget- InThreadShowParent -> p B.<=> replyIndent- InThread -> replyIndent- in if not mdRenderReplyParent- then msgWidget- else case msg^.mInReplyToMsg of- NotAReply -> msgWidget- InReplyTo _ ->- case mdParentMessage of- Nothing -> withParent (B.str "[loading...]")- Just pm ->- let parentMsg = renderMessage md- { mdShowOlderEdits = False- , mdMessage = pm- , mdUserName = mdParentUserName- , mdParentMessage = Nothing- , mdRenderReplyParent = False- , mdIndentBlocks = False- }- in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg)-- where- layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Blocks -> ViewL Block -> Widget Name- layout hs w nameElems bs xs | length xs > 1 = multiLnLayout hs w nameElems bs- layout hs w nameElems bs (C.Blockquote {} :< _) = multiLnLayout hs w nameElems bs- layout hs w nameElems bs (C.CodeBlock {} :< _) = multiLnLayout hs w nameElems bs- layout hs w nameElems bs (C.HtmlBlock {} :< _) = multiLnLayout hs w nameElems bs- layout hs w nameElems bs (C.List {} :< _) = multiLnLayout hs w nameElems bs- layout hs w nameElems bs (C.Para inlns :< _)- | F.any breakCheck inlns = multiLnLayout hs w nameElems bs- layout hs w nameElems bs _ = nameNextToMessage hs w nameElems bs-- multiLnLayout hs w nameElems bs =- if mdIndentBlocks- then vBox [ hBox nameElems- , hBox [B.txt " ", renderMarkdown mdMyUsername hs ((subtract 2) <$> w) bs]- ]- else nameNextToMessage hs w nameElems bs-- nameNextToMessage hs w nameElems bs =- Widget Fixed Fixed $ do- nameResult <- render $ hBox nameElems- let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w- render $ hBox [raw (nameResult^.imageL), renderMarkdown mdMyUsername hs newW bs]-- breakCheck C.LineBreak = True- breakCheck C.SoftBreak = True- breakCheck _ = False--addEllipsis :: Widget a -> Widget a-addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do- ctx <- B.getContext- let aw = ctx^.B.availWidthL- result <- B.render w- let withEllipsis = (B.hLimit (aw - 3) $ B.vLimit 1 $ (B.Widget B.Fixed B.Fixed $ return result)) <+>- B.str "..."- if (V.imageHeight (result^.B.imageL) > 1) || (V.imageWidth (result^.B.imageL) == aw) then- B.render withEllipsis else- return result---- Cursor sentinel for tracking the user's cursor position in previews.-cursorSentinel :: Char-cursorSentinel = '‸'---- Render markdown with username highlighting-renderMarkdown :: Text -> HighlightSet -> Maybe Int -> Blocks -> Widget a-renderMarkdown curUser hSet w =- B.vBox . toList . fmap (blockToWidget curUser hSet w) . addBlankLines---- Add blank lines only between adjacent elements of the same type, to--- save space-addBlankLines :: Seq Block -> Seq Block-addBlankLines = go' . viewl- where go' EmptyL = S.empty- go' (x :< xs) = go x (viewl xs)- go a@C.Para {} (b@C.Para {} :< rs) =- a <| blank <| go b (viewl rs)- go a@C.Header {} (b@C.Header {} :< rs) =- a <| blank <| go b (viewl rs)- go a@C.Blockquote {} (b@C.Blockquote {} :< rs) =- a <| blank <| go b (viewl rs)- go a@C.List {} (b@C.List {} :< rs) =- a <| blank <| go b (viewl rs)- go a@C.CodeBlock {} (b@C.CodeBlock {} :< rs) =- a <| blank <| go b (viewl rs)- go a@C.HtmlBlock {} (b@C.HtmlBlock {} :< rs) =- a <| blank <| go b (viewl rs)- go x (y :< rs) = x <| go y (viewl rs)- go x (EmptyL) = S.singleton x- blank = C.Para (S.singleton (C.Str " "))---- Render text to markdown without username highlighting-renderText :: Text -> Widget a-renderText txt = renderText' "" emptyHSet txt--renderText' :: Text -> HighlightSet -> Text -> Widget a-renderText' curUser hSet txt = renderMarkdown curUser hSet Nothing bs- where C.Doc _ bs = C.markdown C.def txt--vBox :: F.Foldable f => f (Widget a) -> Widget a-vBox = B.vBox . toList--hBox :: F.Foldable f => f (Widget a) -> Widget a-hBox = B.hBox . toList--header :: Int -> Widget a-header n = B.txt (T.replicate n "#")--maybeHLimit :: Maybe Int -> Widget a -> Widget a-maybeHLimit Nothing w = w-maybeHLimit (Just i) w = hLimit i w--blockToWidget :: Text -> HighlightSet -> Maybe Int -> Block -> Widget a-blockToWidget curUser hSet w (C.Para is) =- toInlineChunk curUser w is hSet-blockToWidget curUser hSet w (C.Header n is) =- B.withDefAttr clientHeaderAttr $- hBox [B.padRight (B.Pad 1) $ header n, toInlineChunk curUser (subtract 1 <$> w) is hSet]-blockToWidget curUser hSet w (C.Blockquote is) =- maybeHLimit w $- addQuoting (vBox $ fmap (blockToWidget curUser hSet w) is)-blockToWidget curUser hSet w (C.List _ l bs) =- maybeHLimit w $- blocksToList curUser l w bs hSet-blockToWidget _ hSet _ (C.CodeBlock ci tx) =- let f = maybe rawCodeBlockToWidget (codeBlockToWidget (hSyntaxMap hSet)) mSyntax- mSyntax = Sky.lookupSyntax (C.codeLang ci) (hSyntaxMap hSet)- in f tx-blockToWidget _ _ w (C.HtmlBlock txt) =- maybeHLimit w $- textWithCursor txt-blockToWidget _ _ w (C.HRule) =- maybeHLimit w $- B.vLimit 1 (B.fill '*')--quoteChar :: Char-quoteChar = '>'--addQuoting :: B.Widget n -> B.Widget n-addQuoting w =- B.Widget B.Fixed (B.vSize w) $ do- ctx <- B.getContext- childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w-- let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height- height = V.imageHeight $ childResult^.B.imageL-- B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder- , B.Widget B.Fixed B.Fixed $ return childResult- ]--codeBlockToWidget :: Sky.SyntaxMap -> Sky.Syntax -> Text -> Widget a-codeBlockToWidget syntaxMap syntax tx =- let result = Sky.tokenize cfg syntax tx- cfg = Sky.TokenizerConfig syntaxMap False- in case result of- Left _ -> rawCodeBlockToWidget tx- Right tokLines ->- let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)- in (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=>- (padding <+> BS.renderRawSource textWithCursor tokLines)--rawCodeBlockToWidget :: Text -> Widget a-rawCodeBlockToWidget tx =- B.withDefAttr codeAttr $- let padding = B.padLeftRight 1 (B.vLimit (length theLines) B.vBorder)- theLines = expandEmpty <$> T.lines tx- expandEmpty "" = " "- expandEmpty s = s- in padding <+> (B.vBox $ textWithCursor <$> theLines)--toInlineChunk :: Text -> Maybe Int -> Inlines -> HighlightSet -> Widget a-toInlineChunk curUser w is hSet = B.Widget B.Fixed B.Fixed $ do- ctx <- B.getContext- let width = fromMaybe (ctx^.B.availWidthL) w- fs = toFragments hSet is- ws = fmap (gatherWidgets curUser) (split width hSet fs)- B.render (vBox (fmap hBox ws))--blocksToList :: Text -> ListType -> Maybe Int -> [Blocks] -> HighlightSet -> Widget a-blocksToList curUser lt w bs hSet = vBox- [ B.txt i <+> (vBox (fmap (blockToWidget curUser hSet w) b))- | b <- bs | i <- is ]- where is = case lt of- C.Bullet _ -> repeat ("• ")- C.Numbered C.PeriodFollowing s ->- [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]- C.Numbered C.ParenFollowing s ->- [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ]---- We want to do word-wrapping, but for that we want a linear--- sequence of chunks we can break up. The typical Markdown--- format doesn't fit the bill: when it comes to bold or italic--- bits, we'd have treat it all as one. This representation is--- more amenable to splitting up those bits.-data Fragment = Fragment- { fTextual :: TextFragment- , _fStyle :: FragmentStyle- } deriving (Show, Eq)--data TextFragment- = TStr Text- | TSpace- | TSoftBreak- | TLineBreak- | TLink Text- | TRawHtml Text- | TEditSentinel- | TEditRecentlySentinel- | TComplex (Seq Fragment)- deriving (Show, Eq)--data FragmentStyle- = Normal- | Emph- | Strong- | Code- | User Text- | Link Text- | Emoji- | Channel- | Edited- | EditedRecently- deriving (Eq, Show)--unsafeGetStr :: C.Inline -> Text-unsafeGetStr (C.Str t) = t-unsafeGetStr _ = error "BUG: unsafeGetStr called on non-Str Inline"--toFragments :: HighlightSet -> Inlines -> Seq Fragment-toFragments hSet = go Normal- where go n c = case viewl c of- C.Str t :< xs | t == editMarkingSentinel ->- Fragment TEditSentinel Edited <| go n xs- C.Str t :< xs | t == editRecentlyMarkingSentinel ->- Fragment TEditRecentlySentinel EditedRecently <| go n xs- C.Str t :< xs | userSigil `T.isPrefixOf` t ->- let (uFrags, rest) = takeWhileNameFragment $ F.toList xs- t' = T.concat $ t : (unsafeGetStr <$> F.toList uFrags)- u = T.drop 1 t'- sty = if u `Set.member` (hUserSet hSet)- then User u- else n- in Fragment (TStr t') sty <| go n (S.fromList rest)- C.Str t :< xs | normalChannelSigil `T.isPrefixOf` t ->- let (cFrags, rest) = S.spanl isNameFragment xs- cn = T.concat $ t : (unsafeGetStr <$> F.toList cFrags)- sty = if cn `Set.member` (hChannelSet hSet)- then Channel- else n- in Fragment (TStr cn) sty <| go n rest- C.Str t :< xs ->- Fragment (TStr t) n <| go n xs- C.Space :< xs ->- Fragment TSpace n <| go n xs- C.SoftBreak :< xs ->- Fragment TSoftBreak n <| go n xs- C.LineBreak :< xs ->- Fragment TLineBreak n <| go n xs- C.Link label url _ :< xs ->- case toList label of- [C.Str s] | s == url -> Fragment (TLink url) (Link url) <| go n xs- _ -> Fragment (TComplex $ toFragments hSet label) (Link url) <| go n xs- C.RawHtml t :< xs ->- Fragment (TRawHtml t) n <| go n xs- C.Code t :< xs ->- let ts = [ Fragment frag Code- | wd <- T.split (== ' ') t- , frag <- case wd of- "" -> [TSpace]- _ -> [TSpace, TStr wd]- ]- ts' = case ts of- (Fragment TSpace _:rs) -> rs- _ -> ts- in S.fromList ts' <> go n xs- C.Emph is :< xs ->- go Emph is <> go n xs- C.Strong is :< xs ->- go Strong is <> go n xs- C.Image altIs url _ :< xs ->- Fragment (TStr ("[image" <> altInlinesString altIs <> "]")) (Link url) <| go n xs- C.Entity t :< xs ->- Fragment (TStr t) (Link t) <| go n xs- EmptyL -> S.empty--data SplitState = SplitState- { splitChunks :: Seq (Seq Fragment)- , splitCurrCol :: Int- }--separate :: HighlightSet -> Seq Fragment -> Seq Fragment-separate hSet sq = case viewl sq of- Fragment (TStr s) n :< xs -> gatherStrings s n xs- Fragment x n :< xs -> Fragment x n <| separate hSet xs- EmptyL -> S.empty- where HighlightSet { hUserSet = uSet, hChannelSet = cSet } = hSet- gatherStrings s n rs =- let s' = removeCursor s- in case viewl rs of- _ | (userSigil `T.isPrefixOf` s' && (T.toLower (T.drop 1 s') `Set.member` uSet)) ->- buildString s n <| separate hSet rs- _ | (normalChannelSigil `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` cSet)) ->- buildString s n <| separate hSet rs- Fragment (TStr s'') _ :< _- | s'' == userSigil || s'' == normalChannelSigil ->- buildString s n <| separate hSet rs- Fragment (TStr s'') n' :< xs- | n == n' -> gatherStrings (s <> s'') n xs- Fragment _ _ :< _ -> buildString s n <| separate hSet rs- EmptyL -> S.singleton (buildString s n)- buildString s n =- let s' = removeCursor s- in if | n == Code -> Fragment (TStr s) n- | ":" `T.isPrefixOf` s' &&- ":" `T.isSuffixOf` s' &&- textWidth s' > 2 ->- Fragment (TStr s) Emoji- | Just uname <- userSigil `T.stripPrefix` removeCursor s- , removeCursor (T.toLower uname) `Set.member` uSet ->- Fragment (TStr s) (User uname)- | normalChannelSigil `T.isPrefixOf` (removeCursor s) &&- (T.drop 1 (removeCursor s) `Set.member` cSet) ->- Fragment (TStr s) Channel- | otherwise -> Fragment (TStr s) n--removeCursor :: Text -> Text-removeCursor = T.filter (/= cursorSentinel)--split :: Int -> HighlightSet -> Seq Fragment -> Seq (Seq Fragment)-split maxCols hSet = splitChunks- . go (SplitState (S.singleton S.empty) 0)- . separate hSet- where go st (viewl-> f :< fs) = go st' fs- where st' =- if | fTextual f == TSoftBreak || fTextual f == TLineBreak ->- st { splitChunks = splitChunks st |> S.empty- , splitCurrCol = 0- }- | available >= fsize ->- st { splitChunks = addFragment f (splitChunks st)- , splitCurrCol = splitCurrCol st + fsize- }- | fTextual f == TSpace ->- st { splitChunks = splitChunks st |> S.empty- , splitCurrCol = 0- }- | otherwise ->- st { splitChunks = splitChunks st |> S.singleton f- , splitCurrCol = fsize- }- available = maxCols - splitCurrCol st- fsize = fragmentSize f- addFragment x (viewr-> ls :> l) = ( ls |> (l |> x))- addFragment _ _ = error "[unreachable]"- go st _ = st--fragmentSize :: Fragment -> Int-fragmentSize f = case fTextual f of- TStr t -> textWidth t- TLink t -> textWidth t- TRawHtml t -> textWidth t- TEditSentinel -> textWidth editMarking- TEditRecentlySentinel -> textWidth editMarking- TSpace -> 1- TLineBreak -> 0- TSoftBreak -> 0- TComplex fs -> sum $ fragmentSize <$> fs--strOf :: TextFragment -> Text-strOf f = case f of- TStr t -> t- TLink t -> t- TRawHtml t -> t- TEditSentinel -> editMarking- TEditRecentlySentinel -> editMarking- TSpace -> " "- TComplex fs -> T.concat $ F.toList $ (strOf . fTextual) <$> fs- _ -> ""---- This finds adjacent string-ey fragments and concats them, so--- we can use fewer widgets-gatherWidgets :: Text -> Seq Fragment -> Seq (Widget a)-gatherWidgets curUser (viewl-> (Fragment frag style :< rs)) = go style (strOf frag) rs- where go s t (viewl-> (Fragment f s' :< xs))- | s == s' = go s (t <> strOf f) xs- go s t xs =- let rawText = B.txt (removeCursor t)- rawWidget = case s of- Normal -> rawText- Emph -> B.withDefAttr clientEmphAttr rawText- Edited -> B.withDefAttr editedMarkingAttr $ B.txt t- EditedRecently -> B.withDefAttr editedRecentlyMarkingAttr $ B.txt t- Strong -> B.withDefAttr clientStrongAttr rawText- Code -> B.withDefAttr codeAttr rawText- Link l ->- B.hyperlink l $ B.withDefAttr urlAttr $ case frag of- TComplex fs ->- hBox $ gatherWidgets curUser fs- _ ->- rawText- Emoji -> B.withDefAttr emojiAttr rawText- User u -> colorUsername curUser u t- Channel -> B.withDefAttr channelNameAttr rawText- widget- | T.any (== cursorSentinel) t = B.visible rawWidget- | otherwise = rawWidget- in widget <| gatherWidgets curUser xs-gatherWidgets _ _ =- S.empty--textWithCursor :: Text -> Widget a-textWithCursor t- | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t- | otherwise = B.txt t--findVerbatimChunk :: C.Blocks -> Maybe Text-findVerbatimChunk = getFirst . F.foldMap go- where go (C.CodeBlock _ t) = First (Just t)- go _ = First Nothing
src/State/Autocomplete.hs view
@@ -25,6 +25,7 @@ import Network.Mattermost.Types (userId, channelId) import qualified Network.Mattermost.Endpoints as MM +import Constants ( userSigil, normalChannelSigil ) import {-# SOURCE #-} Command ( commandList, printArgSpec ) import State.Common import {-# SOURCE #-} State.Editing ( Direction(..), tabComplete )@@ -159,10 +160,10 @@ , MentionChannel ] extras = [ SpecialMention m | m <- specials- , (T.toLower searchString) `T.isInfixOf` specialMentionName m+ , (T.toLower searchString) `T.isPrefixOf` specialMentionName m ] - return $ Just $ setCompletionAlternatives ctx searchString (extras <> alts) ty+ return $ Just $ setCompletionAlternatives ctx searchString (alts <> extras) ty doChannelAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () doChannelAutoCompletion ty ctx searchString = do
src/State/ChannelSelect.hs view
@@ -17,6 +17,7 @@ import qualified Network.Mattermost.Types as MM +import Constants ( userSigil, normalChannelSigil ) import Types import qualified Zipper as Z
src/State/Channels.hs view
@@ -10,7 +10,6 @@ , refreshChannelById , applyPreferenceChange , leaveChannel- , leaveChannelIfPossible , leaveCurrentChannel , getNextUnreadChannel , getNextUnreadUserOrChannel@@ -48,13 +47,15 @@ , beginCurrentChannelDeleteConfirm , toggleChannelListVisibility , showChannelInSidebar+ , updateChannelNotifyProps ) where import Prelude () import Prelude.MH -import Brick.Main ( viewportScroll, vScrollToBeginning, invalidateCache, invalidateCacheEntry )+import Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning+ , invalidateCache, invalidateCacheEntry ) import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL ) import Control.Concurrent.Async ( runConcurrently, Concurrently(..) ) import Control.Exception ( SomeException, try )@@ -68,12 +69,14 @@ import qualified Data.Text as T import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL ) import Data.Time.Clock ( getCurrentTime )+import qualified Graphics.Vty as Vty import Lens.Micro.Platform import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Lenses import Network.Mattermost.Types +import Constants ( normalChannelSigil ) import InputHistory import State.Common import {-# SOURCE #-} State.Messages ( fetchVisibleIfNeeded )@@ -102,14 +105,24 @@ prefs <- use (csResources.crUserPreferences) now <- liftIO getCurrentTime config <- use (csResources.crConfiguration)- csFocus %= Z.updateList (mkChannelZipperList now config cconfig prefs cs us) + let zl = mkChannelZipperList now config cconfig prefs cs us+ csFocus %= Z.updateList zl+ -- Schedule the current sidebar for user status updates at the end -- of this MH action. newZ <- use csFocus myId <- gets myUserId scheduleUserStatusFetches $ myId : userIdsFromZipper newZ + -- Update the window title based on the unread status of the+ -- channels.+ let anyUnread = any channelListGroupHasUnread $ fst <$> zl+ title = "matterhorn" <> if anyUnread then "(*)" else ""++ vty <- mh getVtyHandle+ liftIO $ Vty.setWindowTitle vty title+ -- If the zipper rebuild caused the current channel to change, such -- as when the previously-focused channel was removed, we need to -- call fetchVisibleIfNeeded on the newly-focused channel to ensure@@ -942,9 +955,10 @@ startLeaveCurrentChannel :: MH () startLeaveCurrentChannel = do cInfo <- use (csCurrentChannel.ccInfo)- case canLeaveChannel cInfo of- True -> setMode LeaveChannelConfirm- False -> mhError $ GenericError "The /leave command cannot be used with this channel."+ case cInfo^.cdType of+ Direct -> hideDMChannel (cInfo^.cdChannelId)+ Group -> hideDMChannel (cInfo^.cdChannelId)+ _ -> setMode LeaveChannelConfirm deleteCurrentChannel :: MH () deleteCurrentChannel = do@@ -1061,3 +1075,8 @@ if chType /= Direct then setMode DeleteChannelConfirm else mhError $ GenericError "Direct message channels cannot be deleted."++updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH ()+updateChannelNotifyProps cId notifyProps = do+ mh $ invalidateCacheEntry ChannelSidebar+ csChannel(cId).ccInfo.cdNotifyProps .= notifyProps
src/State/Common.hs view
@@ -53,6 +53,7 @@ import State.Async import Types import Types.Common+import Types.RichText ( unURL ) -- * Client Messages@@ -287,7 +288,7 @@ "https://github.com/matterhorn-chat/matterhorn" prepareLink :: LinkChoice -> IO [String]-prepareLink link = return [T.unpack $ link^.linkURL]+prepareLink link = return [T.unpack $ unURL $ link^.linkURL] prepareAttachment :: FileId -> Session -> IO [String] prepareAttachment fId sess = do
src/State/MessageSelect.hs view
@@ -35,10 +35,10 @@ import Network.Mattermost.Types import Clipboard ( copyToClipboard )-import Markdown ( findVerbatimChunk ) import State.Common import State.Messages import Types+import Types.RichText ( findVerbatimChunk ) import Types.Common import Windows.ViewMessage @@ -148,11 +148,13 @@ Nothing -> error "BUG: openSelectedMessageURLs: no selected message available" Just m -> return m + remainInSelectMode <- use (csResources.crConfiguration.to configMessageSelectAfterURLOpen)+ let urls = msgURLs curMsg when (not (null urls)) $ do openedAll <- and <$> mapM (openURL . OpenLinkChoice) urls case openedAll of- True -> setMode Main+ True -> when (not remainInSelectMode) $ setMode Main False -> mhError $ ConfigOptionMissing "urlOpenCommand"
src/State/Messages.hs view
@@ -96,7 +96,11 @@ status <- use csConnectionStatus case status of Disconnected -> do- let m = "Cannot send messages while disconnected."+ let m = T.concat [ "Cannot send messages while disconnected. Enable logging to "+ , "get disconnection information. If Matterhorn's reconnection "+ , "attempts are failing, use `/reconnect` to attempt to "+ , "reconnect manually."+ ] mhError $ GenericError m Connected -> do session <- getSession
+ src/State/NotifyPrefs.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module State.NotifyPrefs+ ( enterEditNotifyPrefsMode+ , exitEditNotifyPrefsMode+ )+where++import Prelude ()+import Prelude.MH++import Types++import Network.Mattermost.Types ( ChannelNotifyProps+ , User(..)+ , UserNotifyProps(..)+ , Type(..)+ , channelNotifyPropsMarkUnread+ , channelNotifyPropsIgnoreChannelMentions+ , WithDefault(..)+ , NotifyOption(..)+ )++import Brick+import Brick.Forms+import Lens.Micro.Platform ( Lens', (.=), lens )++muteLens :: Lens' ChannelNotifyProps Bool+muteLens = lens (\props -> props^.channelNotifyPropsMarkUnreadL == IsValue NotifyOptionMention)+ (\props muted -> props { channelNotifyPropsMarkUnread =+ if muted+ then IsValue NotifyOptionMention+ else IsValue NotifyOptionAll+ })++channelMentionLens :: Lens' ChannelNotifyProps Bool+channelMentionLens = lens (\props -> props^.channelNotifyPropsIgnoreChannelMentionsL == IsValue True)+ (\props ignoreChannelMentions ->+ props { channelNotifyPropsIgnoreChannelMentions = if ignoreChannelMentions+ then IsValue True+ else Default+ })++notifyOptionName :: NotifyOption -> Text+notifyOptionName NotifyOptionAll = "All activity"+notifyOptionName NotifyOptionMention = "Mentions"+notifyOptionName NotifyOptionNone = "Never"++mkNotifyButtons :: ((WithDefault NotifyOption) -> Name)+ -> Lens' ChannelNotifyProps (WithDefault NotifyOption)+ -> NotifyOption+ -> ChannelNotifyProps+ -> FormFieldState ChannelNotifyProps e Name+mkNotifyButtons mkName l globalDefault =+ let optTuple opt = (IsValue opt, mkName $ IsValue opt, notifyOptionName opt)+ defaultField = (Default, mkName Default, "Global default (" <> notifyOptionName globalDefault <> ")")+ nonDefault = optTuple <$> [ NotifyOptionAll+ , NotifyOptionMention+ , NotifyOptionNone+ ]+ in radioField l (defaultField : nonDefault)++notifyPrefsForm :: UserNotifyProps -> ChannelNotifyProps -> Form ChannelNotifyProps e Name+notifyPrefsForm globalDefaults =+ newForm [ checkboxField muteLens MuteToggleField "Mute channel"+ , (padTop $ Pad 1) @@= checkboxField channelMentionLens ChannelMentionsField "Ignore channel mentions"+ , radioStyle "Desktop notifications" @@=+ mkNotifyButtons DesktopNotificationsField channelNotifyPropsDesktopL (userNotifyPropsDesktop globalDefaults)+ , radioStyle "Push notifications" @@=+ mkNotifyButtons PushNotificationsField channelNotifyPropsPushL (userNotifyPropsPush globalDefaults)+ ]+ where radioStyle label = (padTop $ Pad 1 ) . (str label <=>) . (padLeft $ Pad 1)++enterEditNotifyPrefsMode :: MH ()+enterEditNotifyPrefsMode = do+ chanInfo <- use (csCurrentChannel.ccInfo)+ case chanInfo^.cdType of+ Direct -> mhError $ GenericError "Cannot open notification preferences for DM channel."+ _ -> do+ let props = chanInfo^.cdNotifyProps+ user <- use csMe+ csNotifyPrefs .= (Just (notifyPrefsForm (userNotifyProps user) props))+ setMode EditNotifyPrefs++exitEditNotifyPrefsMode :: MH ()+exitEditNotifyPrefsMode = do+ setMode Main
src/State/Setup.hs view
@@ -151,6 +151,7 @@ result <- loadCustomizations absPath baseTheme case result of Left e -> do+ Vty.shutdown teamSelVty putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e exitFailure Right t -> return t
+ src/State/ThemeListOverlay.hs view
@@ -0,0 +1,86 @@+module State.ThemeListOverlay+ ( enterThemeListMode++ , themeListSelectDown+ , themeListSelectUp+ , themeListPageDown+ , themeListPageUp++ , setTheme+ )+where++import Prelude ()+import Prelude.MH++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 State.ListOverlay+import Themes+import Types+++-- | Show the user list overlay with the given search scope, and issue a+-- request to gather the first search results.+enterThemeListMode :: MH ()+enterThemeListMode =+ enterListOverlayMode csThemeListOverlay ThemeListOverlay () setInternalTheme getThemesMatching++-- | Move the selection up in the user list overlay by one user.+themeListSelectUp :: MH ()+themeListSelectUp = themeListMove L.listMoveUp++-- | Move the selection down in the user list overlay by one user.+themeListSelectDown :: MH ()+themeListSelectDown = themeListMove L.listMoveDown++-- | Move the selection up in the user list overlay by a page of users+-- (themeListPageSize).+themeListPageUp :: MH ()+themeListPageUp = themeListMove (L.listMoveBy (-1 * themeListPageSize))++-- | Move the selection down in the user list overlay by a page of users+-- (themeListPageSize).+themeListPageDown :: MH ()+themeListPageDown = themeListMove (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 :: (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH ()+themeListMove = listOverlayMove csThemeListOverlay++-- | 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 :: InternalTheme -> MH Bool+setInternalTheme t = do+ setTheme $ internalThemeName t+ return False++setTheme :: Text -> MH ()+setTheme name =+ case lookupTheme name of+ Nothing -> enterThemeListMode+ Just it -> do+ mh invalidateCache+ csResources.crTheme .= (themeToAttrMap $ internalTheme it)
− src/State/Themes.hs
@@ -1,34 +0,0 @@-module State.Themes- (- listThemes- , setTheme- )-where--import Prelude ()-import Prelude.MH--import Brick ( invalidateCache )-import Brick.Themes ( themeToAttrMap )-import qualified Data.Text as T-import Lens.Micro.Platform ( (.=) )--import State.Common-import Themes-import Types---listThemes :: MH ()-listThemes = do- let themeList = T.intercalate "\n" $- "Available built-in themes:\n" :- (("* " <>) <$> internalThemeName <$> internalThemes)- postInfoMessage themeList--setTheme :: Text -> MH ()-setTheme name =- case lookupTheme name of- Nothing -> listThemes- Just it -> do- mh invalidateCache- csResources.crTheme .= (themeToAttrMap $ internalTheme it)
src/State/UserListOverlay.hs view
@@ -18,12 +18,13 @@ import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Data.Vector as Vec-import Lens.Micro.Platform ( (.~) )+import Lens.Micro.Platform ( (.~), (.=) ) import qualified Network.Mattermost.Endpoints as MM import qualified Network.Mattermost.Types.Config as MM import Network.Mattermost.Types +import State.Async ( doAsyncWith, AsyncPriority(Preempt) ) import State.Channels ( createOrFocusDMChannel, addUserToCurrentChannel ) import State.ListOverlay import Types@@ -36,12 +37,17 @@ cId <- use csCurrentChannelId myId <- gets myUserId myTId <- gets myTeamId- enterUserListMode (ChannelMembers cId myTId)- (\u -> case u^.uiId /= myId of- True -> createOrFocusDMChannel u Nothing >> return True- False -> return False- )+ session <- getSession + doAsyncWith Preempt $ do+ stats <- MM.mmGetChannelStatistics cId session+ return $ Just $ do+ enterUserListMode (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats)+ (\u -> case u^.uiId /= myId of+ True -> createOrFocusDMChannel 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.@@ -50,7 +56,7 @@ cId <- use csCurrentChannelId myId <- gets myUserId myTId <- gets myTeamId- enterUserListMode (ChannelNonMembers cId myTId)+ enterUserListMode (ChannelNonMembers cId myTId) Nothing (\u -> case u^.uiId /= myId of True -> addUserToCurrentChannel u >> return True False -> return False@@ -66,7 +72,7 @@ let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of Just MM.RestrictTeam -> Just myTId _ -> Nothing- enterUserListMode (AllUsers restrictTeam)+ enterUserListMode (AllUsers restrictTeam) Nothing (\u -> case u^.uiId /= myId of True -> createOrFocusDMChannel u Nothing >> return True False -> return False@@ -74,8 +80,9 @@ -- | Show the user list overlay with the given search scope, and issue a -- request to gather the first search results.-enterUserListMode :: UserSearchScope -> (UserInfo -> MH Bool) -> MH ()-enterUserListMode scope enterHandler =+enterUserListMode :: UserSearchScope -> Maybe Int -> (UserInfo -> MH Bool) -> MH ()+enterUserListMode scope resultCount enterHandler = do+ csUserListOverlay.listOverlayRecordCount .= resultCount enterListOverlayMode csUserListOverlay UserListOverlay scope enterHandler getUserSearchResults userInfoFromPair :: User -> Text -> UserInfo
src/TeamSelect.hs view
@@ -18,7 +18,7 @@ import Network.Mattermost.Types -import Markdown+import Draw.RichText import Types.Common
src/Themes.hs view
@@ -52,6 +52,8 @@ -- * Username formatting , colorUsername+ , attrForUsername+ , usernameColorHashBuckets ) where @@ -66,6 +68,7 @@ , attrMappingsForStyle , highlightedCodeBlockAttr )+import Brick.Forms ( focusedFormInputAttr ) import Data.Hashable ( hash ) import qualified Data.Map as M import qualified Data.Text as T@@ -73,7 +76,7 @@ import qualified Skylighting.Styles as Sky import Skylighting.Types ( TokenType(..) ) -import Types ( specialUserMentions )+import Types ( InternalTheme(..), specialUserMentions ) helpAttr :: AttrName@@ -199,18 +202,15 @@ messageSelectStatusAttr :: AttrName messageSelectStatusAttr = "messageSelectStatus" -data InternalTheme =- InternalTheme { internalThemeName :: Text- , internalTheme :: Theme- }- lookupTheme :: Text -> Maybe InternalTheme lookupTheme n = find ((== n) . internalThemeName) internalThemes internalThemes :: [InternalTheme] internalThemes = validateInternalTheme <$> [ darkColorTheme+ , darkColor256Theme , lightColorTheme+ , lightColor256Theme ] validateInternalTheme :: InternalTheme -> InternalTheme@@ -230,14 +230,23 @@ defaultTheme = darkColorTheme lightColorTheme :: InternalTheme-lightColorTheme = InternalTheme name theme+lightColorTheme = InternalTheme name theme desc where- theme = newTheme def lightAttrs+ theme = newTheme def $ lightAttrs usernameColors16 name = "builtin:light" def = black `on` white+ desc = "A color theme for terminal windows with light background colors" -lightAttrs :: [(AttrName, Attr)]-lightAttrs =+lightColor256Theme :: InternalTheme+lightColor256Theme = InternalTheme name theme desc+ where+ theme = newTheme def $ lightAttrs usernameColors256+ name = "builtin:light256"+ def = black `on` white+ desc = "Like builtin:light, but with 256-color username colors"++lightAttrs :: [Attr] -> [(AttrName, Attr)]+lightAttrs usernameColors = let sty = Sky.kate in [ (timeAttr, fg black) , (currentUserAttr, defAttr `withStyle` bold)@@ -279,6 +288,7 @@ , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, black `on` yellow) , (tabSelectedAttr, black `on` yellow)+ , (focusedFormInputAttr, black `on` yellow) , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue) , (FB.fileBrowserSelectionInfoAttr, white `on` blue) , (FB.fileBrowserDirectoryAttr, fg blue)@@ -288,11 +298,11 @@ , (FB.fileBrowserSymbolicLinkAttr, fg cyan) , (FB.fileBrowserUnixSocketAttr, fg red) ] <>- ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <>+ ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..usernameColorHashBuckets-1] (cycle usernameColors)) <> (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty) -darkAttrs :: [(AttrName, Attr)]-darkAttrs =+darkAttrs :: [Attr] -> [(AttrName, Attr)]+darkAttrs usernameColors = let sty = Sky.espresso in [ (timeAttr, fg white) , (currentUserAttr, defAttr `withStyle` bold)@@ -334,6 +344,7 @@ , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, black `on` yellow) , (tabSelectedAttr, black `on` yellow)+ , (focusedFormInputAttr, black `on` yellow) , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue) , (FB.fileBrowserSelectionInfoAttr, white `on` blue) , (FB.fileBrowserDirectoryAttr, fg blue)@@ -343,19 +354,28 @@ , (FB.fileBrowserSymbolicLinkAttr, fg cyan) , (FB.fileBrowserUnixSocketAttr, fg red) ] <>- ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <>+ ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..usernameColorHashBuckets-1] (cycle usernameColors)) <> (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty) skipBaseCodeblockAttr :: (AttrName, Attr) -> Bool skipBaseCodeblockAttr = ((/= highlightedCodeBlockAttr) . fst) darkColorTheme :: InternalTheme-darkColorTheme = InternalTheme name theme+darkColorTheme = InternalTheme name theme desc where- theme = newTheme def darkAttrs+ theme = newTheme def $ darkAttrs usernameColors16 name = "builtin:dark" def = defAttr+ desc = "A color theme for terminal windows with dark background colors" +darkColor256Theme :: InternalTheme+darkColor256Theme = InternalTheme name theme desc+ where+ theme = newTheme def $ darkAttrs usernameColors256+ name = "builtin:dark256"+ def = defAttr+ desc = "Like builtin:dark, but with 256-color username colors"+ usernameAttr :: Int -> AttrName usernameAttr i = "username" <> (attrName $ show i) @@ -388,11 +408,7 @@ -- ^ The text to render -> Widget a colorUsername current username display =- let normalizedUsername = T.toLower username- aName = if normalizedUsername `elem` specialUserMentions- then clientEmphAttr- else usernameAttr h- h = hash normalizedUsername `mod` length usernameColors+ let aName = attrForUsername username maybeWithCurrentAttr = if current == username then withAttr currentUserAttr else id@@ -400,8 +416,33 @@ maybeWithCurrentAttr $ txt (display) -usernameColors :: [Attr]-usernameColors =+-- | Return the attribute name to use for the specified username.+-- The input username is expected to be the username only (i.e. no+-- sigil).+--+-- If the input username is a special reserved username such as "all",+-- the @clientEmphAttr@ attribute name will be returned. Otherwise+-- a hash-bucket username attribute name will be returned based on+-- the hash value of the username and the number of hash buckets+-- (@usernameColorHashBuckets@).+attrForUsername :: Text+ -- ^ The username to get an attribute for+ -> AttrName+attrForUsername username =+ let normalizedUsername = T.toLower username+ aName = if normalizedUsername `elem` specialUserMentions+ then clientEmphAttr+ else usernameAttr h+ h = hash normalizedUsername `mod` usernameColorHashBuckets+ in aName++-- | The number of hash buckets to use when hashing usernames to choose+-- their colors.+usernameColorHashBuckets :: Int+usernameColorHashBuckets = 50++usernameColors16 :: [Attr]+usernameColors16 = [ fg red , fg green , fg yellow@@ -416,6 +457,54 @@ , fg brightCyan ] +usernameColors256 :: [Attr]+usernameColors256 = mkColor <$> username256ColorChoices+ where+ mkColor (r, g, b) = defAttr `withForeColor` rgbColor r g b++username256ColorChoices :: [(Integer, Integer, Integer)]+username256ColorChoices =+ [ (255, 0, 86)+ , (158, 0, 142)+ , (14, 76, 161)+ , (255, 229, 2)+ , (149, 0, 58)+ , (255, 147, 126)+ , (164, 36, 0)+ , (98, 14, 0)+ , (0, 0, 255)+ , (106, 130, 108)+ , (0, 174, 126)+ , (194, 140, 159)+ , (0, 143, 156)+ , (95, 173, 78)+ , (255, 2, 157)+ , (255, 116, 163)+ , (152, 255, 82)+ , (167, 87, 64)+ , (254, 137, 0)+ , (1, 208, 255)+ , (187, 136, 0)+ , (117, 68, 177)+ , (165, 255, 210)+ , (122, 71, 130)+ , (0, 71, 84)+ , (181, 0, 255)+ , (144, 251, 146)+ , (189, 211, 147)+ , (229, 111, 254)+ , (222, 255, 116)+ , (0, 255, 120)+ , (0, 155, 255)+ , (0, 100, 1)+ , (0, 118, 255)+ , (133, 169, 0)+ , (0, 185, 23)+ , (120, 130, 49)+ , (0, 255, 198)+ , (255, 110, 65)+ ]+ -- Functions for dealing with Skylighting styles attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe Text@@ -642,6 +731,9 @@ , ( listSelectedFocusedAttr , "The selected channel" )+ , ( focusedFormInputAttr+ , "A form input that has focus"+ ) , ( FB.fileBrowserAttr , "The base file browser attribute" )@@ -676,5 +768,5 @@ , "Attribute for the username of the user running Matterhorn" ) ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i)- | i <- [0..(length usernameColors)-1]+ | i <- [0..usernameColorHashBuckets-1] ]
src/Types.hs view
@@ -58,9 +58,13 @@ , RequestChan , UserFetch(..) , writeBChan+ , InternalTheme(..) + , attrNameToConfig+ , mkChannelZipperList , ChannelListGroup(..)+ , channelListGroupHasUnread , trimChannelSigil @@ -81,6 +85,7 @@ , csPostMap , csRecentChannel , csReturnChannel+ , csThemeListOverlay , csPostListOverlay , csUserListOverlay , csChannelListOverlay@@ -96,6 +101,8 @@ , csClientConfig , csPendingChannelChange , csViewedMessage+ , csNotifyPrefs+ , csMe , timeZone , whenMode , setMode@@ -146,6 +153,7 @@ , listOverlayEnterHandler , listOverlayNewList , listOverlayFetchResults+ , listOverlayRecordCount , getUsers @@ -252,8 +260,6 @@ , getNewMessageCutoff , getEditedMessageCutoff - , normalChannelSigil- , HighlightSet(..) , UserSet , ChannelSet@@ -272,9 +278,11 @@ import qualified Graphics.Vty as Vty import qualified Brick import Brick ( EventM, Next, Widget )+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, list ) import qualified Brick.Widgets.FileBrowser as FB@@ -288,6 +296,7 @@ import qualified Data.Set as Set import qualified Data.ByteString as BS import qualified Data.Foldable as F+import qualified Data.Kind as K import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM import Data.List ( sortBy, nub, elemIndex )@@ -314,6 +323,7 @@ import Network.Mattermost.Types.Config import Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse ) +import Constants ( userSigil, normalChannelSigil ) import InputHistory import Emoji import Types.Common@@ -341,13 +351,19 @@ | TokenCommand Text deriving (Eq, Read, Show) --- | The type of channel list group headings.+-- | The type of channel list group headings. Booleans indicate whether+-- any channels in the group have unread activity. data ChannelListGroup =- ChannelGroupPublicChannels- | ChannelGroupPrivateChannels- | ChannelGroupDirectMessages+ ChannelGroupPublicChannels Bool+ | ChannelGroupPrivateChannels Bool+ | ChannelGroupDirectMessages Bool deriving (Eq) +channelListGroupHasUnread :: ChannelListGroup -> Bool+channelListGroupHasUnread (ChannelGroupPublicChannels u) = u+channelListGroupHasUnread (ChannelGroupPrivateChannels u) = u+channelListGroupHasUnread (ChannelGroupDirectMessages u) = u+ -- | The type of channel list entries. data ChannelListEntry = CLChannel ChannelId@@ -438,6 +454,9 @@ -- ^ The CPU usage policy for the application. , configDefaultAttachmentPath :: Maybe FilePath -- ^ The default path for browsing attachments+ , configMessageSelectAfterURLOpen :: Bool+ -- ^ Whether to remain in message selection mode after+ -- opening URL(s) } deriving (Eq, Show) -- | The policy for CPU usage.@@ -481,8 +500,10 @@ hasUnread' chan = fromMaybe False $ do let info = _ccInfo chan lastViewTime <- _cdViewed info- return $ ((_cdUpdated info) > lastViewTime) ||- (isJust $ _cdEditedMessageThreshold info)+ return $ _cdMentionCount info > 0 ||+ (not (isMuted chan) &&+ ((_cdUpdated info) > lastViewTime) ||+ (isJust $ _cdEditedMessageThreshold info)) mkChannelZipperList :: UTCTime -> Config@@ -492,28 +513,32 @@ -> Users -> [(ChannelListGroup, [ChannelListEntry])] mkChannelZipperList now config cconfig prefs cs us =- [ (ChannelGroupPublicChannels, getChannelIdsInOrder cs Ordinary)- , (ChannelGroupPrivateChannels, getChannelIdsInOrder cs Private)- , (ChannelGroupDirectMessages, getDMChannelsInOrder now config cconfig prefs us cs)+ [ let (anyUnread, entries) = getChannelEntriesInOrder cs Ordinary+ in (ChannelGroupPublicChannels anyUnread, entries)+ , let (anyUnread, entries) = getChannelEntriesInOrder cs Private+ in (ChannelGroupPrivateChannels anyUnread, entries)+ , (ChannelGroupDirectMessages False, getDMChannelEntriesInOrder now config cconfig prefs us cs) ] -getChannelIdsInOrder :: ClientChannels -> Type -> [ChannelListEntry]-getChannelIdsInOrder cs ty =+getChannelEntriesInOrder :: ClientChannels -> Type -> (Bool, [ChannelListEntry])+getChannelEntriesInOrder cs ty = let matches (_, info) = info^.ccInfo.cdType == ty- in fmap (CLChannel . fst) $- sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) $- filteredChannels matches cs+ pairs = filteredChannels matches cs+ anyUnread = or $ (hasUnread' . snd) <$> pairs+ entries = fmap (CLChannel . fst) $+ sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) pairs+ in (anyUnread, entries) -getDMChannelsInOrder :: UTCTime- -> Config- -> Maybe ClientConfig- -> UserPreferences- -> Users- -> ClientChannels- -> [ChannelListEntry]-getDMChannelsInOrder now config cconfig prefs us cs =- let oneOnOneDmChans = getDMChannels now config cconfig prefs us cs- groupChans = getGroupDMChannels now config prefs cs+getDMChannelEntriesInOrder :: UTCTime+ -> Config+ -> Maybe ClientConfig+ -> UserPreferences+ -> Users+ -> ClientChannels+ -> [ChannelListEntry]+getDMChannelEntriesInOrder now config cconfig prefs us cs =+ let oneOnOneDmChans = getDMChannelEntries now config cconfig prefs us cs+ groupChans = getGroupDMChannelEntries now config prefs cs allDmChans = groupChans <> oneOnOneDmChans sorter (u1, n1, _) (u2, n2, _) = if u1 == u2@@ -541,25 +566,25 @@ | otherwise = u^.uiName -getGroupDMChannels :: UTCTime- -> Config- -> UserPreferences- -> ClientChannels- -> [(Bool, T.Text, ChannelListEntry)]-getGroupDMChannels now config prefs cs =+getGroupDMChannelEntries :: UTCTime+ -> Config+ -> UserPreferences+ -> ClientChannels+ -> [(Bool, T.Text, ChannelListEntry)]+getGroupDMChannelEntries now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group && groupChannelShouldAppear now config prefs info in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdDisplayName, CLGroupDM cId)) $ filteredChannels matches cs -getDMChannels :: UTCTime- -> Config- -> Maybe ClientConfig- -> UserPreferences- -> Users- -> ClientChannels- -> [(Bool, T.Text, ChannelListEntry)]-getDMChannels now config cconfig prefs us cs =+getDMChannelEntries :: UTCTime+ -> Config+ -> Maybe ClientConfig+ -> UserPreferences+ -> Users+ -> ClientChannels+ -> [(Bool, T.Text, ChannelListEntry)]+getDMChannelEntries now config cconfig prefs us cs = let mapping = allDmChannelMappings cs mappingWithUserInfo = catMaybes $ getInfo <$> mapping getInfo (uId, cId) = do@@ -637,9 +662,11 @@ | JoinChannelList | UrlList | MessagePreviewViewport+ | ThemeListSearchInput | UserListSearchInput | JoinChannelListSearchInput | UserListSearchResults+ | ThemeListSearchResults | ViewMessageArea | ViewMessageReactionsArea | ChannelSidebar@@ -650,6 +677,10 @@ | ReactionEmojiList | ReactionEmojiListInput | TabbedWindowTabBar+ | MuteToggleField+ | ChannelMentionsField+ | DesktopNotificationsField (WithDefault NotifyOption)+ | PushNotificationsField (WithDefault NotifyOption) deriving (Eq, Show, Ord) -- | The sum type of exceptions we expect to encounter on authentication@@ -689,27 +720,23 @@ | CLId Int deriving (Eq, Show) --- Sigils-normalChannelSigil :: Text-normalChannelSigil = "~"- -- ** Channel-matching types -- | A match in channel selection mode. data ChannelSelectMatch =- ChannelSelectMatch { nameBefore :: Text+ ChannelSelectMatch { nameBefore :: Text -- ^ The content of the match before the user's -- matching input.- , nameMatched :: Text+ , nameMatched :: Text -- ^ The potion of the name that matched the -- user's input.- , nameAfter :: Text+ , nameAfter :: Text -- ^ The portion of the name that came after the -- user's matching input.- , matchFull :: Text+ , matchFull :: Text -- ^ The full string for this entry so it doesn't -- have to be reassembled from the parts above.- , matchEntry :: ChannelListEntry+ , matchEntry :: ChannelListEntry -- ^ The original entry data corresponding to the -- text match. }@@ -1061,9 +1088,11 @@ | UserListOverlay | ReactionEmojiListOverlay | ChannelListOverlay+ | ThemeListOverlay | ViewMessage | ManageAttachments | ManageAttachmentsBrowseFiles+ | EditNotifyPrefs deriving (Eq) -- | We're either connected or we're not.@@ -1292,6 +1321,8 @@ -- queue length if so. , _csMessageSelect :: MessageSelectState -- ^ The state of message selection mode.+ , _csThemeListOverlay :: ListOverlayState InternalTheme ()+ -- ^ The state of the theme list overlay. , _csPostListOverlay :: PostListOverlayState -- ^ The state of the post list overlay. , _csUserListOverlay :: ListOverlayState UserInfo UserSearchScope@@ -1318,6 +1349,11 @@ -- 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.).+ , _csNotifyPrefs :: 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. } -- | Handles for the View Message window's tabs.@@ -1367,6 +1403,7 @@ , _csConnectionStatus = Connected , _csWorkerIsBusy = Nothing , _csMessageSelect = MessageSelectState Nothing+ , _csThemeListOverlay = nullThemeListOverlayState , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing , _csUserListOverlay = nullUserListOverlayState , _csChannelListOverlay = nullChannelListOverlayState@@ -1374,6 +1411,7 @@ , _csClientConfig = Nothing , _csPendingChannelChange = Nothing , _csViewedMessage = Nothing+ , _csNotifyPrefs = Nothing } nullChannelListOverlayState :: ListOverlayState Channel ChannelSearchScope@@ -1386,8 +1424,22 @@ , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty+ , _listOverlayRecordCount = Nothing } +nullThemeListOverlayState :: ListOverlayState InternalTheme ()+nullThemeListOverlayState =+ let newList rs = list ThemeListSearchResults rs 3+ in ListOverlayState { _listOverlaySearchResults = newList mempty+ , _listOverlaySearchInput = editor ThemeListSearchInput (Just 1) ""+ , _listOverlaySearchScope = ()+ , _listOverlaySearching = False+ , _listOverlayEnterHandler = const $ return False+ , _listOverlayNewList = newList+ , _listOverlayFetchResults = const $ const $ const $ return mempty+ , _listOverlayRecordCount = Nothing+ }+ nullUserListOverlayState :: ListOverlayState UserInfo UserSearchScope nullUserListOverlayState = let newList rs = list UserListSearchResults rs 1@@ -1398,6 +1450,7 @@ , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty+ , _listOverlayRecordCount = Nothing } nullEmojiListOverlayState :: ListOverlayState (Bool, T.Text) ()@@ -1410,6 +1463,7 @@ , _listOverlayEnterHandler = const $ return False , _listOverlayNewList = newList , _listOverlayFetchResults = const $ const $ const $ return mempty+ , _listOverlayRecordCount = Nothing } -- | The state of channel selection mode.@@ -1435,6 +1489,12 @@ , _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 =@@ -1458,6 +1518,8 @@ , _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. } -- | The scope for searching for users in a user list overlay.@@ -1882,7 +1944,7 @@ -- | The 'CmdArgs' type represents the arguments to a slash-command; the -- type parameter represents the argument structure.-data CmdArgs :: * -> * where+data CmdArgs :: K.Type -> K.Type where NoArg :: CmdArgs () LineArg :: Text -> CmdArgs Text UserArg :: CmdArgs rest -> CmdArgs (Text, rest)@@ -1973,6 +2035,9 @@ , hChannelSet = getChannelNameSet $ 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]
src/Types/Channels.hs view
@@ -20,7 +20,7 @@ , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated , cdName, cdDisplayName, cdHeader, cdPurpose, cdType , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId- , cdSidebarShowOverride+ , cdSidebarShowOverride, cdNotifyProps -- * Lenses created for accessing ChannelContents fields , cdMessages, cdFetchPending -- * Creating ClientChannel objects@@ -41,6 +41,11 @@ , addChannelTypingUser -- * Notification settings , notifyPreference+ , isMuted+ , channelNotifyPropsMarkUnreadL+ , channelNotifyPropsIgnoreChannelMentionsL+ , channelNotifyPropsDesktopL+ , channelNotifyPropsPushL -- * Miscellaneous channel-related operations , canLeaveChannel , preferredChannelName@@ -240,11 +245,16 @@ makeLenses ''ClientChannel makeLenses ''EphemeralEditState +isMuted :: ClientChannel -> Bool+isMuted cc = cc^.ccInfo.cdNotifyProps.channelNotifyPropsMarkUnreadL ==+ IsValue NotifyOptionMention+ notifyPreference :: User -> ClientChannel -> NotifyOption notifyPreference u cc =- case cc^.ccInfo.cdNotifyProps.channelNotifyPropsDesktopL of- IsValue v -> v- Default -> (userNotifyProps u)^.userNotifyPropsDesktopL+ if isMuted cc then NotifyOptionNone+ else case cc^.ccInfo.cdNotifyProps.channelNotifyPropsDesktopL of+ IsValue v -> v+ Default -> (userNotifyProps u)^.userNotifyPropsDesktopL -- ** Miscellaneous channel operations
src/Types/KeyEvents.hs view
@@ -88,8 +88,11 @@ | ScrollRightEvent | PageUpEvent | PageDownEvent+ | PageRightEvent+ | PageLeftEvent | ScrollTopEvent | ScrollBottomEvent+ | SelectOldestMessageEvent -- select events---not the same as scrolling sometimes! | SelectUpEvent@@ -118,6 +121,9 @@ | AttachmentListAddEvent | AttachmentListDeleteEvent | AttachmentOpenEvent++ -- Form submission+ | FormSubmitEvent deriving (Eq, Show, Ord, Enum) allEvents :: [KeyEvent]@@ -176,8 +182,11 @@ , ScrollRightEvent , PageUpEvent , PageDownEvent+ , PageLeftEvent+ , PageRightEvent , ScrollTopEvent , ScrollBottomEvent+ , SelectOldestMessageEvent , SelectUpEvent , SelectDownEvent@@ -200,6 +209,7 @@ , AttachmentListAddEvent , AttachmentListDeleteEvent , AttachmentOpenEvent+ , FormSubmitEvent ] eventToBinding :: Vty.Event -> Binding@@ -392,8 +402,11 @@ ScrollRightEvent -> "scroll-right" PageUpEvent -> "page-up" PageDownEvent -> "page-down"+ PageLeftEvent -> "page-left"+ PageRightEvent -> "page-right" ScrollTopEvent -> "scroll-top" ScrollBottomEvent -> "scroll-bottom"+ SelectOldestMessageEvent -> "select-oldest-message" SelectUpEvent -> "select-up" SelectDownEvent -> "select-down"@@ -417,3 +430,5 @@ AttachmentListAddEvent -> "add-to-attachment-list" AttachmentListDeleteEvent -> "delete-from-attachment-list" AttachmentOpenEvent -> "open-attachment"++ FormSubmitEvent -> "submit-form"
src/Types/Messages.hs view
@@ -94,13 +94,12 @@ , removeMatchesFromSubset , withFirstMessage , msgURLs- , altInlinesString , LinkChoice(LinkChoice) , linkUser , linkURL , linkTime- , linkName+ , linkLabel , linkFileId ) where@@ -108,8 +107,6 @@ import Prelude () import Prelude.MH -import Cheapskate ( Blocks )-import qualified Cheapskate as C import Control.Monad import qualified Data.Foldable as F import Data.Hashable ( Hashable )@@ -126,7 +123,10 @@ import Types.DirectionalSeq import Types.Posts-import Types.UserNames+import Types.RichText ( RichTextBlock(..), Element(..)+ , ElementData(..), findUsernames, blockGetURLs+ , ElementStyle(..), URL(..), parseMarkdown+ ) -- | The state of a message's thread context.@@ -155,7 +155,7 @@ -- | A 'Message' is any message we might want to render, either from -- Mattermost itself or from a client-internal source. data Message = Message- { _mText :: Blocks+ { _mText :: Seq RichTextBlock , _mMarkdownSource :: Text , _mUser :: UserRef , _mDate :: ServerTime@@ -286,8 +286,8 @@ data LinkChoice = LinkChoice { _linkTime :: ServerTime , _linkUser :: UserRef- , _linkName :: Text- , _linkURL :: Text+ , _linkLabel :: Maybe (Seq Element)+ , _linkURL :: URL , _linkFileId :: Maybe FileId } deriving (Eq, Show) @@ -299,7 +299,7 @@ -- associated with passing a link to the local browser. clientMessageToMessage :: ClientMessage -> Message clientMessageToMessage cm = Message- { _mText = getBlocks (cm^.cmText)+ { _mText = parseMarkdown (cm^.cmText) , _mMarkdownSource = cm^.cmText , _mUser = NoUser , _mDate = cm^.cmDate@@ -361,7 +361,7 @@ newMessageOfType :: Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message- { _mText = getBlocks text+ { _mText = parseMarkdown text , _mMarkdownSource = text , _mUser = NoUser , _mDate = d@@ -719,51 +719,21 @@ withFirstMessage = withDirSeqHead msgURLs :: Message -> Seq LinkChoice-msgURLs msg- | NoUser <- msg^.mUser = mempty- | otherwise =- let uid = msg^.mUser- msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$>- (mconcat $ blockGetURLs <$> (toList $ msg^.mText))+msgURLs msg =+ let uRef = msg^.mUser+ msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uRef text url Nothing) <$>+ (Seq.fromList $ mconcat $ blockGetURLs <$> (toList $ msg^.mText)) attachmentURLs = (\ a -> LinkChoice (msg^.mDate)- uid- ("attachment `" <> (a^.attachmentName) <> "`")- (a^.attachmentURL)+ uRef+ (Just $ attachmentLabel a)+ (URL $ a^.attachmentURL) (Just (a^.attachmentFileId))) <$> (msg^.mAttachments)+ attachmentLabel a =+ Seq.fromList [ Element Normal $ EText "attachment"+ , Element Normal ESpace+ , Element Code $ EText $ a^.attachmentName+ ] in msgUrls <> attachmentURLs--blockGetURLs :: C.Block -> Seq.Seq (Text, Text)-blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> toList is-blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> toList is-blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> toList bs-blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (toList <$> bss)-blockGetURLs _ = mempty--inlineGetURLs :: C.Inline -> Seq.Seq (Text, Text)-inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> toList is-inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> toList is-inlineGetURLs (C.Link is url "") = (url, inlinesText is) Seq.<| (mconcat $ inlineGetURLs <$> toList is)-inlineGetURLs (C.Link is _ url) = (url, inlinesText is) Seq.<| (mconcat $ inlineGetURLs <$> toList is)-inlineGetURLs (C.Image is url _) = Seq.singleton (url, inlinesText is)-inlineGetURLs _ = mempty--inlinesText :: Seq C.Inline -> Text-inlinesText = F.fold . fmap go- where go (C.Str t) = t- go C.Space = " "- go C.SoftBreak = " "- go C.LineBreak = " "- go (C.Emph is) = F.fold (fmap go is)- go (C.Strong is) = F.fold (fmap go is)- go (C.Code t) = t- go (C.Link is _ _) = F.fold (fmap go is)- go (C.Image is _ _) = "[image" <> altInlinesString is <> "]"- go (C.Entity t) = t- go (C.RawHtml t) = t--altInlinesString :: Seq C.Inline -> Text-altInlinesString is | Seq.null is = ""- | otherwise = ":" <> inlinesText is
src/Types/Posts.hs view
@@ -42,16 +42,12 @@ , postIsJoin , postIsTopicChange , postIsEmote-- , getBlocks ) where import Prelude () import Prelude.MH -import Cheapskate ( Blocks )-import qualified Cheapskate as C import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Text as T@@ -63,6 +59,7 @@ import Network.Mattermost.Types import Types.Common+import Types.RichText ( RichTextBlock(Blockquote), parseMarkdown ) -- * Client Messages@@ -113,7 +110,7 @@ -- the Mattermost 'Post' type, with unnecessary information -- removed and some preprocessing done. data ClientPost = ClientPost- { _cpText :: Blocks+ { _cpText :: Seq RichTextBlock , _cpMarkdownSource :: Text , _cpUser :: Maybe UserId , _cpUserOverride :: Maybe Text@@ -154,10 +151,6 @@ -- ** Creating 'ClientPost' Values --- | Parse text as Markdown and extract the AST-getBlocks :: Text -> Blocks-getBlocks s = bs where C.Doc _ bs = C.markdown C.def s- -- | Determine the internal 'PostType' based on a 'Post' postClientPostType :: Post -> ClientPostType postClientPostType cp =@@ -201,7 +194,7 @@ toClientPost :: Post -> Maybe PostId -> ClientPost toClientPost p parentId = let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p- in ClientPost { _cpText = getBlocks src <> getAttachmentText p+ in ClientPost { _cpText = parseMarkdown src <> getAttachmentText p , _cpMarkdownSource = src , _cpUser = postUserId p , _cpUserOverride = p^.postPropsL.postPropsOverrideUsernameL@@ -221,13 +214,13 @@ -- | Right now, instead of treating 'attachment' properties specially, we're -- just going to roll them directly into the message text-getAttachmentText :: Post -> Blocks+getAttachmentText :: Post -> Seq RichTextBlock getAttachmentText p = case p^.postPropsL.postPropsAttachmentsL of Nothing -> Seq.empty Just attachments ->- fmap (C.Blockquote . render) attachments- where render att = getBlocks (att^.ppaTextL) <> getBlocks (att^.ppaFallbackL)+ fmap (Blockquote . render) attachments+ where render att = parseMarkdown (att^.ppaTextL) <> parseMarkdown (att^.ppaFallbackL) -- ** 'ClientPost' Lenses
+ src/Types/RichText.hs view
@@ -0,0 +1,390 @@+-- | This module provides a set of data types to represent message text.+-- The types here are based loosely on the @cheapskate@ package's types+-- but provide higher-level support for the kinds of things we find in+-- Mattermost messages such as user and channel references.+--+-- To parse a Markdown document, use 'parseMarkdown'. To actually render+-- text in this representation, see the module 'Draw.RichText'.+module Types.RichText+ ( RichTextBlock(..)+ , ListType(..)+ , CodeBlockInfo(..)+ , NumDecoration(..)+ , Element(..)+ , ElementData(..)+ , ElementStyle(..)++ , URL(..)+ , unURL++ , parseMarkdown+ , setElementStyle++ , findUsernames+ , blockGetURLs+ , findVerbatimChunk++ -- Exposed for testing only:+ , fromMarkdownBlocks+ )+where++import Prelude ()+import Prelude.MH++import qualified Cheapskate as C+import Data.Char ( isAlphaNum, isAlpha )+import qualified Data.Foldable as F+import Data.Monoid (First(..))+import qualified Data.Set as S+import qualified Data.Sequence as Seq+import Data.Sequence ( (<|), ViewL((:<)) )+import qualified Data.Text as T++import Constants ( userSigil, normalChannelSigil )++-- | A block in a rich text document.+data RichTextBlock =+ Para (Seq Element)+ -- ^ A paragraph.+ | Header Int (Seq Element)+ -- ^ A section header with specified depth and contents.+ | Blockquote (Seq RichTextBlock)+ -- ^ A blockquote.+ | List Bool ListType (Seq (Seq RichTextBlock))+ -- ^ An itemized list.+ | CodeBlock CodeBlockInfo Text+ -- ^ A code block.+ | HTMLBlock Text+ -- ^ A fragment of raw HTML.+ | HRule+ -- ^ A horizontal rule.+ deriving (Show)++-- | The type of itemized list items.+data ListType =+ Bullet Char+ -- ^ Decorate the items with bullet using the specified character.+ | Numbered NumDecoration Int+ -- ^ Number the items starting at the specified number; use the+ -- indicated decoration following the number.+ deriving (Eq, Show)++-- | Information about a code block.+data CodeBlockInfo =+ CodeBlockInfo { codeBlockLanguage :: Maybe Text+ -- ^ The language of the source code in the code+ -- block, if any. This is encoded in Markdown as a+ -- sequence of non-whitespace characters following the+ -- fenced code block opening backticks.+ , codeBlockInfo :: Maybe Text+ -- ^ Any text that comes after the language token.+ -- This text is separated from the language token by+ -- whitespace.+ }+ deriving (Eq, Show)++-- | Ways to decorate numbered itemized list items. The decoration+-- follows the list item number.+data NumDecoration =+ Paren+ | Period+ deriving (Eq, Show)++-- | A single logical inline element in a rich text block.+data Element =+ Element { eStyle :: ElementStyle+ -- ^ The element's visual style.+ , eData :: ElementData+ -- ^ The element's data.+ }+ deriving (Show, Eq)++setElementStyle :: ElementStyle -> Element -> Element+setElementStyle s e = e { eStyle = s }++-- | A URL.+newtype URL = URL Text+ deriving (Eq, Show, Ord)++unURL :: URL -> Text+unURL (URL url) = url++-- | The kinds of data that can appear in rich text elements.+data ElementData =+ EText Text+ -- ^ A sequence of non-whitespace characters.+ | ESpace+ -- ^ A single space.+ | ESoftBreak+ -- ^ A soft line break.+ | ELineBreak+ -- ^ A hard line break.+ | ERawHtml Text+ -- ^ Raw HTML.+ | EEditSentinel Bool+ -- ^ A sentinel indicating that some text has been edited (used+ -- to indicate that mattermost messages have been edited by their+ -- authors). This has no parsable representation; it is only used+ -- to annotate a message prior to rendering to add a visual editing+ -- indicator. The boolean indicates whether the edit was "recent"+ -- (True) or not (False).+ | EUser Text+ -- ^ A user reference. The text here includes only the username, not+ -- the sigil.+ | EChannel Text+ -- ^ A channel reference. The text here includes only the channel+ -- name, not the sigil.+ | EHyperlink URL (Maybe (Seq Element))+ -- ^ A hyperlink to the specified URL. Optionally provides an+ -- element sequence indicating the URL's text label; if absent, the+ -- label is understood to be the URL itself.+ | EImage URL (Maybe (Seq Element))+ -- ^ An image at the specified URL. Optionally provides an element+ -- sequence indicating the image's "alt" text label; if absent, the+ -- label is understood to be the URL itself.+ | EEmoji Text+ -- ^ An emoji reference. The text here includes only the text+ -- portion, not the colons, e.g. "foo" instead of ":foo:".+ deriving (Show, Eq)++-- | Element visual styles.+data ElementStyle =+ Normal+ -- ^ Normal text+ | Emph+ -- ^ Emphasized text+ | Strong+ -- ^ Bold text+ | Code+ -- ^ Inline code segment or code block+ | Hyperlink URL ElementStyle+ -- ^ A terminal hyperlink to the specified URL, composed with+ -- another element style+ deriving (Eq, Show)++parseMarkdown :: T.Text -> Seq RichTextBlock+parseMarkdown t = fromMarkdownBlocks bs where C.Doc _ bs = C.markdown C.def t++-- | Convert a sequence of markdown (Cheapskate) blocks into rich text+-- blocks.+fromMarkdownBlocks :: C.Blocks -> Seq RichTextBlock+fromMarkdownBlocks = fmap fromMarkdownBlock++-- | Convert a single markdown block into a single rich text block.+fromMarkdownBlock :: C.Block -> RichTextBlock+fromMarkdownBlock (C.Para is) =+ Para $ fromMarkdownInlines is+fromMarkdownBlock (C.Header level is) =+ Header level $ fromMarkdownInlines is+fromMarkdownBlock (C.Blockquote bs) =+ Blockquote $ fromMarkdownBlock <$> bs+fromMarkdownBlock (C.List f ty bss) =+ List f (fromMarkdownListType ty) $ fmap fromMarkdownBlock <$> Seq.fromList bss+fromMarkdownBlock (C.CodeBlock attr body) =+ CodeBlock (fromMarkdownCodeAttr attr) body+fromMarkdownBlock (C.HtmlBlock body) =+ HTMLBlock body+fromMarkdownBlock C.HRule =+ HRule++fromMarkdownCodeAttr :: C.CodeAttr -> CodeBlockInfo+fromMarkdownCodeAttr (C.CodeAttr lang info) =+ let strippedLang = T.strip lang+ strippedInfo = T.strip info+ maybeText t = if T.null t then Nothing else Just t+ in CodeBlockInfo (maybeText strippedLang)+ (maybeText strippedInfo)++fromMarkdownListType :: C.ListType -> ListType+fromMarkdownListType (C.Bullet c) =+ Bullet c+fromMarkdownListType (C.Numbered wrap i) =+ let dec = case wrap of+ C.PeriodFollowing -> Period+ C.ParenFollowing -> Paren+ in Numbered dec i++-- | Convert a sequence of Markdown inline values to a sequence of+-- Elements.+--+-- This conversion converts sequences of Markdown AST fragments into+-- RichText elements. In particular, this function may determine that+-- some sequences of Markdown text fragments belong together, such as+-- the sequence @["@", "joe", "-", "user"]@, which should be treated as+-- a single "@joe-user" token due to username character validation. When+-- appropriate, this function does such consolidation when converting to+-- RichText elements.+--+-- This function is also partially responsible for paving the way for+-- line-wrapping later on when RichText is rendered. This means that,+-- when possible, the elements produced by this function need to be as+-- small as possible, without losing structure information. An example+-- of this is Markdown inline code fragments, such as "`this is code`".+-- This function will convert that one Markdown inline code fragment+-- into a sequence of five RichText elements, each with a "Code" style+-- assigned: @[EText "this", ESpace, EText "is", ESpace, EText "code"]@.+-- This "flattening" of the original Markdown structure makes it much+-- easier to do line-wrapping without losing style information because+-- it is possible to gather up tokens that do not exceed line widths+-- without losing style information. This is key to rendering the text+-- with the right terminal attributes.+--+-- However, there are a couple of cases where such flattening does *not*+-- happen: hyperlinks and images. In these cases we do not flatten the+-- (arbitrary) text label structure of links and images because we need+-- to be able to recover those labels to gather up URLs to show to the+-- user in the URL list. So we leave the complete text structure of+-- those labels behind in the 'EHyperlink' and 'EImage' constructors as+-- sequences of Elements. This means that logic in 'Draw.RichText' that+-- does line-wrapping will have to explicitly break up link and image+-- labels across line breaks.+fromMarkdownInlines :: Seq C.Inline -> Seq Element+fromMarkdownInlines inlines =+ let go sty is = case Seq.viewl is of+ C.Str ":" :< xs ->+ let validEmojiFragment (C.Str f) =+ f `elem` ["_", "-"] || T.all isAlphaNum f+ validEmojiFragment _ = False+ (emojiFrags, rest) = Seq.spanl validEmojiFragment xs+ em = T.concat $ unsafeGetStr <$> F.toList emojiFrags+ in case Seq.viewl rest of+ C.Str ":" :< rest2 ->+ Element Normal (EEmoji em) <| go sty rest2+ _ ->+ Element sty (EText ":") <| go sty xs+ C.Str t :< xs | userSigil `T.isPrefixOf` t ->+ let (uFrags, rest) = Seq.spanl isNameFragment xs+ t' = T.concat $ t : (unsafeGetStr <$> F.toList uFrags)+ u = T.drop 1 t'+ in Element sty (EUser u) <| go sty rest+ C.Str t :< xs | normalChannelSigil `T.isPrefixOf` t ->+ let (cFrags, rest) = Seq.spanl isNameFragment xs+ cn = T.drop 1 $ T.concat $ t : (unsafeGetStr <$> F.toList cFrags)+ in Element sty (EChannel cn) <| go sty rest+ C.Str t :< xs ->+ -- When we encounter a string node, we go ahead and+ -- process the rest of the nodes in the sequence. If the+ -- new sequence starts with *another* string node with+ -- the same style, we merge them. We do this because+ -- Cheapskate will parse things like punctuation as+ -- individual string nodes, but we want to keep those+ -- together with any text is adjacent to them to avoid+ -- e.g. breaking up quotes from quoted text when doing+ -- line-wrapping. It's important to make sure we only do+ -- this for adjacent string (i.e. not whitespace) nodes+ -- and that we make sure we only merge when they have the+ -- same style.+ let rest = go sty xs+ e = Element sty (EText t)+ in case Seq.viewl rest of+ Element sty2 (EText t2) :< tail_ | sty2 == sty ->+ (Element sty (EText (t <> t2))) <| tail_+ _ ->+ e <| rest+ C.Space :< xs ->+ Element sty ESpace <| go sty xs+ C.SoftBreak :< xs ->+ Element sty ESoftBreak <| go sty xs+ C.LineBreak :< xs ->+ Element sty ELineBreak <| go sty xs+ C.Link label theUrl _ :< xs ->+ let mLabel = if Seq.null label+ then Nothing+ else Just $ fromMarkdownInlines label+ url = URL theUrl+ in (Element (Hyperlink url sty) $ EHyperlink url mLabel) <| go sty xs+ C.Image altIs theUrl _ :< xs ->+ let mLabel = if Seq.null altIs+ then Nothing+ else Just $ fromMarkdownInlines altIs+ url = URL theUrl+ in (Element (Hyperlink url sty) $ EImage url mLabel) <| go sty xs+ C.RawHtml t :< xs ->+ Element sty (ERawHtml t) <| go sty xs+ C.Code t :< xs ->+ -- We turn a single code string into individual Elements+ -- so we can perform line-wrapping on the inline code+ -- text.+ let ts = [ Element Code frag+ | wd <- T.split (== ' ') t+ , frag <- case wd of+ "" -> [ESpace]+ _ -> [ESpace, EText wd]+ ]+ ts' = case ts of+ (Element _ ESpace:rs) -> rs+ _ -> ts+ in Seq.fromList ts' <> go sty xs+ C.Emph as :< xs ->+ go Emph as <> go sty xs+ C.Strong as :< xs ->+ go Strong as <> go sty xs+ C.Entity t :< xs ->+ Element sty (EText t) <| go sty xs+ Seq.EmptyL -> mempty++ in go Normal inlines++unsafeGetStr :: C.Inline -> Text+unsafeGetStr (C.Str t) = t+unsafeGetStr _ = error "BUG: unsafeGetStr called on non-Str Inline"++-- | Obtain all username references in a sequence of rich text blocks.+findUsernames :: Seq RichTextBlock -> S.Set T.Text+findUsernames = S.unions . F.toList . fmap blockFindUsernames++blockFindUsernames :: RichTextBlock -> S.Set T.Text+blockFindUsernames (Para is) =+ elementFindUsernames $ F.toList is+blockFindUsernames (Header _ is) =+ elementFindUsernames $ F.toList is+blockFindUsernames (Blockquote bs) =+ findUsernames bs+blockFindUsernames (List _ _ bs) =+ S.unions $ F.toList $ findUsernames <$> bs+blockFindUsernames _ =+ mempty++elementFindUsernames :: [Element] -> S.Set T.Text+elementFindUsernames [] = mempty+elementFindUsernames (e : es) =+ case eData e of+ EUser u -> S.insert u $ elementFindUsernames es+ _ -> elementFindUsernames es++-- | Obtain all URLs (and optional labels) in a rich text block.+blockGetURLs :: RichTextBlock -> [(URL, Maybe (Seq Element))]+blockGetURLs (Para is) =+ catMaybes $ elementGetURL <$> toList is+blockGetURLs (Header _ is) =+ catMaybes $ elementGetURL <$> toList is+blockGetURLs (Blockquote bs) =+ mconcat $ blockGetURLs <$> toList bs+blockGetURLs (List _ _ bss) =+ mconcat $ mconcat $+ (fmap blockGetURLs . F.toList) <$> F.toList bss+blockGetURLs _ =+ mempty++elementGetURL :: Element -> Maybe (URL, Maybe (Seq Element))+elementGetURL (Element _ (EHyperlink url label)) =+ Just (url, label)+elementGetURL (Element _ (EImage url label)) =+ Just (url, label)+elementGetURL _ =+ Nothing++-- | Find the first code block in a sequence of rich text blocks.+findVerbatimChunk :: Seq RichTextBlock -> Maybe Text+findVerbatimChunk = getFirst . F.foldMap go+ where go (CodeBlock _ t) = First (Just t)+ go _ = First Nothing++isValidNameChar :: Char -> Bool+isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-'++isNameFragment :: C.Inline -> Bool+isNameFragment (C.Str t) =+ not (T.null t) && isValidNameChar (T.head t)+isNameFragment _ = False
− src/Types/UserNames.hs
@@ -1,70 +0,0 @@-module Types.UserNames- ( findUsernames- , isNameFragment- , takeWhileNameFragment- )-where--import qualified Cheapskate as C-import Data.Char ( isAlpha )-import qualified Data.Foldable as F-import qualified Data.Set as S-import qualified Data.Text as T--import Prelude ()-import Prelude.MH---findUsernames :: C.Blocks -> S.Set T.Text-findUsernames = S.unions . F.toList . fmap blockFindUsernames--blockFindUsernames :: C.Block -> S.Set T.Text-blockFindUsernames (C.Para is) =- inlineFindUsernames $ F.toList is-blockFindUsernames (C.Header _ is) =- inlineFindUsernames $ F.toList is-blockFindUsernames (C.Blockquote bs) =- findUsernames bs-blockFindUsernames (C.List _ _ bs) =- S.unions $ F.toList $ findUsernames <$> bs-blockFindUsernames _ =- mempty--inlineFindUsernames :: [C.Inline] -> S.Set T.Text-inlineFindUsernames [] = mempty-inlineFindUsernames (C.Str "@" : rest) =- let (strs, remaining) = takeWhileNameFragment rest- in if null strs- then inlineFindUsernames remaining- else S.insert (T.concat $ getInlineStr <$> strs) $ inlineFindUsernames remaining-inlineFindUsernames (_ : rest) =- inlineFindUsernames rest--getInlineStr :: C.Inline -> T.Text-getInlineStr (C.Str s) = s-getInlineStr _ = ""--takeWhileNameFragment :: [C.Inline] -> ([C.Inline], [C.Inline])-takeWhileNameFragment [] = ([], [])-takeWhileNameFragment rest =- let (strs, remaining) = break (not . isNameFragment) rest- -- Does the last element in strs start with a letter? If- -- not, move it to the remaining list. This avoids pulling- -- punctuation-only tokens into usernames, e.g. "Hello,- -- @foobar."- (strs', remaining') =- if length strs <= 1- then (strs, remaining)- else let (initStrs, [lastStr]) = splitAt (length strs - 1) strs- in if isAlpha $ T.head $ getInlineStr lastStr- then (strs, remaining)- else (initStrs, lastStr : remaining)- in (strs', remaining')--isValidNameChar :: Char -> Bool-isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-'--isNameFragment :: C.Inline -> Bool-isNameFragment (C.Str t) =- not (T.null t) && isValidNameChar (T.head t)-isNameFragment _ = False
src/Types/Users.hs view
@@ -13,7 +13,6 @@ , userInfoFromUser -- * Miscellaneous , getUsernameSet- , userSigil , trimUserSigil , statusFromText , findUserById@@ -43,6 +42,7 @@ import Network.Mattermost.Types ( UserId(..), User(..) ) import Types.Common+import Constants ( userSigil ) -- * 'UserInfo' Values @@ -184,9 +184,6 @@ case filter ((== (Just $ trimUserSigil nick)) . _uiNickName . snd) $ HM.toList $ _ofUsers us of (pair : []) -> Just pair _ -> Nothing--userSigil :: Text-userSigil = "@" trimUserSigil :: Text -> Text trimUserSigil n
src/Windows/ViewMessage.hs view
@@ -25,7 +25,7 @@ import Events.Keybindings import Themes import Types-import Markdown+import Draw.RichText import Draw.Messages ( nameForUserRef ) -- | The template for "View Message" windows triggered by message@@ -165,6 +165,12 @@ , mkKb PageDownEvent "Page down" $ mh $ vScrollBy vs pageAmount++ , mkKb PageLeftEvent "Page left" $+ mh $ hScrollBy vs (-2 * pageAmount)++ , mkKb PageRightEvent "Page right" $+ mh $ hScrollBy vs (2 * pageAmount) , mkKb ScrollUpEvent "Scroll up" $ mh $ vScrollBy vs (-1)
test/Message_QCA.hs view
@@ -15,6 +15,7 @@ import Test.Tasty.QuickCheck import Types.Messages import Types.Posts+import Types.RichText genMap :: Ord key => Gen key -> Gen value -> Gen (Map key value) genMap gk gv = let kv = (,) <$> gk <*> gv in fromList <$> listOf kv@@ -30,7 +31,7 @@ genMessage :: Gen Message genMessage = Message- <$> genBlocks+ <$> (fromMarkdownBlocks <$> genBlocks) <*> genText <*> genUserRef <*> genTime@@ -58,7 +59,7 @@ genMessage__DeletedPost :: Gen Message__DeletedPost genMessage__DeletedPost = Message__DeletedPost <$> (Message- <$> genBlocks+ <$> (fromMarkdownBlocks <$> genBlocks) <*> genText <*> genUserRef <*> genTime@@ -80,7 +81,7 @@ genMessage__Posted :: Gen Message__Posted genMessage__Posted = Message__Posted <$> (Message- <$> genBlocks+ <$> (fromMarkdownBlocks <$> genBlocks) <*> genText <*> genUserRef <*> genTime