diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,48 @@ +40900.0.0 +========= + +This release supports Mattermost server version 4.9. + +New features: + * Matterhorn now supports activity notifications by ivoking a + user-configured external command. The external command is configured + with the `activityNotifyCommand` setting. Matterhorn also includes + an example notification script for Linux-based systems in the + `notification-scripts` directory. Thanks to Jason Miller for this + feature! + * Matterhorn now bundles syntax highlighting language descriptions + rather compiling them into the binary. This resolves issue #372. + The XML descriptions are in the Kate project's language description + format and are provided with their accompanying GPL license. + Syntax description files are loaded from a prioritized list + of directories. The list of directories is configurable using + the optional `syntaxDirectories` configuration setting. See + `sample_config.ini` for details. + * Matterhorn now tab-completes available syntax highlighting language + options on lines starting with the code block Markdown syntax (three + backticks) (#354). + +Other changes: + * Tab-completion now always fills in user sigil on username and + nickname completions, and fills in channel sigils on channel name + completions. + * Usernames in posts are now only highlighted when a user sigil is + present. + +Bug fixes: + * Matterhorn now switches to a channel after it has been joined (#355). + * Fixed emote editing (#388). + +40800.0.3 +========= + +Bug fixes: + * Fixed a bug that prevented DM channel changes when the DM channels + were named with user nicknames (#384) + * "Resource vanished" exceptions will no longer be silenced during + async work. + 40800.0.2 ========= diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016, Getty Ritter +Copyright (c) 2016-2018, AUTHORS.txt All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/PRACTICES.md b/PRACTICES.md --- a/PRACTICES.md +++ b/PRACTICES.md @@ -13,6 +13,47 @@ * We want to manage inevitable software evolution, and * We want to reduce waste through good team coordination. +Aesthetics +---------- + +When working with the code, we do not have a "style guide" and do not +want to enumerate all the different ways that the code can or should +be formatted. We also recognize that the specific formatting +decisions are often affected by editor behaviors and individual typing +habits. + +The ultimate goal is readability and so in general, we recommend that +you loosely follow existing formatting by default (eyes like to see +familiar patterns), but feel free to implement specific practices where +these match the editor tooling and or your personal aesthetics. + +The following are some of the aesthetic choices we've made; these are +not hard rules but help to explain the current overall appearance: + + * Imports are usually in alphabetical order and separated into 4-5 + sections from the most global/generic to the most local/specific. + Because there can be a number of sections, we separate the imports + from the module body with two lines to help visually locate this + point. See Events.hs as an example. + + * We have collected the most common Prelude elements into a local + file included by all modules (and therefore hiding the normal + Prelude). This helps to reduce the number of overall imports, and + we keep this as the first import section to draw attention to the + fact that the normal Prelude is not in context by default. + + * We prefer not to mix the `.` and `$` operators on the same line: + + ```haskell + let foo = func . chain . call $ parse $ input + let foo = func $ chain $ call $ parse $ input -- preferred + ``` + + * Top-level functions have haddock documentation to help describe + what the function is used for (and sometimes ways in which it + shouldn't be used). + + Branching --------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -159,6 +159,8 @@ and `HTTPS_PROXY` environment variables. (Plain HTTP proxies are not yet supported.) * Multiple color themes with color theme customization support +* Custom notifications via notification scripts (see the + `activityNotifyCommand` configuration setting). # Spell Checking Support diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 40800.0.2 +version: 40900.0.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 @@ -20,6 +20,7 @@ scripts/cowsay scripts/figlet scripts/rot13 + notification-scripts/notify source-repository head type: git @@ -93,7 +94,7 @@ NoImplicitPrelude ghc-options: -Wall -threaded -with-rtsopts=-I0 build-depends: base >=4.8 && <5 - , mattermost-api == 40800.0.1 + , mattermost-api == 40900.0.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 @@ -102,11 +103,11 @@ , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 , stm >= 2.4 && < 2.5 - , config-ini >= 0.1.2 && < 0.2 + , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4 , brick >= 0.36 && < 0.37 - , brick-skylighting >= 0.1 && < 0.2 + , brick-skylighting >= 0.2 && < 0.3 , vty >= 5.20 && < 5.21 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 @@ -127,7 +128,7 @@ , aspell-pipe >= 0.3 && < 0.4 , stm-delay >= 0.1 && < 0.2 , unix >= 2.7.1.0 && < 2.7.3.0 - , skylighting >= 0.6 && < 0.7 + , skylighting-core >= 0.7 && < 0.8 , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2 , aeson >= 1.2.3.0 && < 1.3 @@ -155,15 +156,15 @@ , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5 - , config-ini >= 0.1.2 && < 0.2 + , config-ini >= 0.2.2.0 && < 0.3 , connection >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 40800.0.1 - , mattermost-api-qc == 40800.0.1 + , mattermost-api == 40900.0.0 + , mattermost-api-qc == 40900.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 diff --git a/notification-scripts/notify b/notification-scripts/notify new file mode 100644 --- /dev/null +++ b/notification-scripts/notify @@ -0,0 +1,38 @@ +#!/bin/sh +############################################################# +# Sample shell-script for using notify-send with matterhorn # +############################################################# + +# Positional parameters +mentioned="${1?}" +sender="${2?}" +message="${3?}" + +# Script options + +# notify_URGENCIES +# First word is urgency for items where you are not mentioned, the second is +# urgency for items where you are mentioned. Use "none" to not be notified, +# otherwise low, normal, critical are options +notify_URGENCIES="normal normal" +#notify_URGENCIES="none normal" +# The desktop notification category +notify_CATEGORY="im.received" +# Notification header +notify_HEAD="Matterhorn message from $sender" +# Notification body +notify_BODY="$message" + +getUrgencyHelper() { + shift "$mentioned" + echo "$1" +} + +getUrgency() { + # we are using arguments as a poor-mans bash array for portability + # shellcheck disable=SC2086 + getUrgencyHelper $notify_URGENCIES +} + +test "$(getUrgency)" = "none" || + notify-send -u "$(getUrgency)" -c "$notify_CATEGORY" "$notify_HEAD" "$notify_BODY" diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -8,22 +8,23 @@ import Prelude.MH import Brick -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Except ( runExceptT ) import qualified Graphics.Vty as Vty -import System.IO (IOMode(WriteMode), openFile, hClose) -import Text.Aspell (stopAspell) +import System.IO ( IOMode(WriteMode), openFile, hClose ) +import Text.Aspell ( stopAspell ) import Network.Mattermost import Config -import Options -import InputHistory +import Draw +import Events import IOUtil +import InputHistory import LastRunState +import Options import State.Setup -import Events -import Draw import Types + app :: App ChatState MHEvent Name app = App diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -2,25 +2,27 @@ {-# LANGUAGE OverloadedStrings #-} module Command where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import qualified Control.Exception as Exn import qualified Data.Char as Char import qualified Data.Text as T + import qualified Network.Mattermost.Endpoints as MM -import qualified Network.Mattermost.Types as MM import qualified Network.Mattermost.Exceptions as MM +import qualified Network.Mattermost.Types as MM -import State -import State.Editing (toggleMessagePreview) -import State.Common -import State.PostListOverlay -import State.UserListOverlay -import Types -import HelpTopics -import Scripts +import HelpTopics +import Scripts +import State +import State.Common +import State.Editing ( toggleMessagePreview ) +import State.PostListOverlay +import State.UserListOverlay +import Types + -- | This function skips any initial whitespace and returns the first -- 'token' (i.e. any sequence of non-whitespace characters) as well as -- the trailing rest of the string, after any whitespace. This is used @@ -108,11 +110,7 @@ , Cmd "help" "Show help about a particular topic" (TokenArg "topic" NoArg) $ \ (topicName, ()) -> case lookupHelpTopic topicName of - Nothing -> do - let msg = ("Unknown help topic: `" <> topicName <> "`. " <> - (T.unlines $ "Available topics are:" : knownTopics)) - knownTopics = (" - " <>) <$> helpTopicName <$> helpTopics - mhError msg + Nothing -> mhError $ NoSuchHelpTopic topicName Just topic -> showHelpScreen topic , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> @@ -152,11 +150,11 @@ , MM.minComCommand = "/" <> name <> " " <> rest , MM.minComParentId = case em of Replying _ p -> Just $ MM.getId p - Editing p -> MM.postParentId p + Editing p _ -> MM.postParentId p _ -> Nothing , MM.minComRootId = case em of Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p) - Editing p -> MM.postRootId p + Editing p _ -> MM.postRootId p _ -> Nothing , MM.minComTeamId = tId } @@ -180,7 +178,7 @@ case errMsg of Nothing -> return () Just err -> - mhError ("Error running command: " <> err) + mhError $ GenericError ("Error running command: " <> err) dispatchCommand :: Text -> MH () dispatchCommand cmd = @@ -195,7 +193,7 @@ go errs [] = do let msg = ("error running command /" <> x <> ":\n" <> mconcat [ " " <> e | e <- errs ]) - mhError msg + mhError $ GenericError msg go errs (Cmd _ _ spec exe : cs) = case matchArgs spec xs of Left e -> go (e:errs) cs diff --git a/src/Completion.hs b/src/Completion.hs --- a/src/Completion.hs +++ b/src/Completion.hs @@ -2,6 +2,7 @@ -- https://github.com/glguy/irc-core/blob/v2/src/Client/Commands/WordCompletion.hs module Completion ( Completer(..) + , CompletionAlternative(..) , wordComplete , currentAlternative , nextCompletion @@ -18,31 +19,47 @@ import qualified Zipper as Z + -- A completer stores the stateful selection of a completion alternative --- from a sequence of alternatives. Each item in the sequence is a pair: --- the first element of the pair is the string corresonding to the user --- input and the second element of the pair is what will ultimately --- replace the user's input. The two are decoupled specifically to deal --- with permitting nickname completions to "resolve" to usernames. +-- from a sequence of alternatives. data Completer = - Completer { completionAlternatives :: Z.Zipper (Text, Text) + Completer { completionAlternatives :: Z.Zipper CompletionAlternative } +-- A completion alternative is made up of various representations: +-- the string corresonding to the user input, the string that will +-- ultimately replace the user's input, and the the string that we will +-- display in the alternative list. The representations are decoupled +-- specifically to deal with permitting nickname completions to +-- "resolve" to usernames and to permit completions in context-sensitive +-- settings where the completion replacement and display differ greatly +-- from the input. +data CompletionAlternative = + CompletionAlternative { completionInput :: Text + , completionReplacement :: Text + , completionDisplay :: Text + } + deriving (Ord, Eq) + +matchesAlternative :: Text -> CompletionAlternative -> Bool +matchesAlternative input alt = + T.toLower input `T.isPrefixOf` (T.toLower $ completionInput alt) + -- Nothing: no completions. -- Just Left: a single completion. -- Just Right: more than one completion. -wordComplete :: Set (Text, Text) -> Text -> Maybe (Either Text Completer) +wordComplete :: Set CompletionAlternative -> Text -> Maybe (Either Text Completer) wordComplete options input = let curWord = currentWord input - alts = sort $ Set.toList $ Set.filter ((curWord `T.isPrefixOf`) . fst) options + alts = sort $ Set.toList $ Set.filter (matchesAlternative curWord) options in if null alts || T.null curWord then Nothing else if length alts == 1 - then Just $ Left $ snd $ head alts + then Just $ Left $ completionReplacement $ head alts else Just $ Right $ Completer { completionAlternatives = Z.fromList alts } -currentAlternative :: Completer -> (Text, Text) +currentAlternative :: Completer -> CompletionAlternative currentAlternative = Z.focus . completionAlternatives nextCompletion :: Completer -> Completer diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -1,12 +1,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} module Config ( Config(..) , PasswordSource(..) , findConfig , getCredentials - , defaultConfig - ) where + ) +where import Prelude () import Prelude.MH @@ -16,17 +17,50 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.IO as T -import System.Directory (makeAbsolute) -import System.Process (readProcess) +import System.Directory ( makeAbsolute ) +import System.Environment ( getExecutablePath ) +import System.FilePath ( (), takeDirectory, splitPath, joinPath ) +import System.Process ( readProcess ) -import IOUtil import FilePaths +import IOUtil import Types import Types.KeyEvents + defaultPort :: Int defaultPort = 443 +bundledSyntaxPlaceholderName :: String +bundledSyntaxPlaceholderName = "BUNDLED_SYNTAX" + +userSyntaxPlaceholderName :: String +userSyntaxPlaceholderName = "USER_SYNTAX" + +defaultSkylightingPaths :: IO [FilePath] +defaultSkylightingPaths = do + xdg <- xdgSyntaxDir + adjacent <- getBundledSyntaxPath + return [xdg, adjacent] + +getBundledSyntaxPath :: IO FilePath +getBundledSyntaxPath = do + selfPath <- getExecutablePath + let distDir = "dist-newstyle/" + pathBits = splitPath selfPath + + return $ if distDir `elem` pathBits + then + -- We're in development, so use the development + -- executable path to locate the XML path in the + -- development tree. + (joinPath $ takeWhile (/= distDir) pathBits) syntaxDirName + else + -- In this case we assume the binary is being run from + -- a release, in which case the syntax directory is a + -- sibling of the executable path. + takeDirectory selfPath syntaxDirName + fromIni :: IniParser Config fromIni = do conf <- section "mattermost" $ do @@ -55,6 +89,8 @@ (configShowTypingIndicator defaultConfig) configEnableAspell <- fieldFlagDef "enableAspell" (configEnableAspell defaultConfig) + configSyntaxDirs <- fieldDefOf "syntaxDirectories" syntaxDirsField [] + configActivityNotifyCommand <- fieldMb "activityNotifyCommand" configActivityBell <- fieldFlagDef "activityBell" (configActivityBell defaultConfig) configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs" @@ -76,6 +112,9 @@ Just binding -> return (Just (ev, binding)) return conf { configUserKeys = fromMaybe mempty keys } +syntaxDirsField :: Text -> Either String [FilePath] +syntaxDirsField = listWithSeparator ":" string + backgroundField :: Text -> Either String BackgroundInfo backgroundField t = case t of @@ -120,6 +159,7 @@ , configSmartBacktick = True , configURLOpenCommand = Nothing , configURLOpenCommandInteractive = False + , configActivityNotifyCommand = Nothing , configActivityBell = False , configShowBackground = Disabled , configShowMessagePreview = False @@ -131,15 +171,35 @@ , configUserKeys = mempty , configShowTypingIndicator = False , configHyperlinkingMode = True + , configSyntaxDirs = [] } findConfig :: Maybe FilePath -> IO (Either String Config) findConfig Nothing = do cfg <- locateConfig configFileName - case cfg of + fixupSyntaxDirs =<< case cfg of Nothing -> return $ Right defaultConfig Just path -> getConfig path -findConfig (Just path) = getConfig path +findConfig (Just path) = fixupSyntaxDirs =<< getConfig path + +-- | If the configuration has no syntax directories specified (the +-- default if the user did not provide the setting), fill in the +-- list with the defaults. Otherwise replace any bundled directory +-- placeholders in the config's syntax path list. +fixupSyntaxDirs :: Either String Config -> IO (Either String Config) +fixupSyntaxDirs (Left e) = return $ Left e +fixupSyntaxDirs (Right c) = + if configSyntaxDirs c == [] + then do + dirs <- defaultSkylightingPaths + return $ Right c { configSyntaxDirs = dirs } + else do + newDirs <- forM (configSyntaxDirs c) $ \dir -> + if | dir == bundledSyntaxPlaceholderName -> getBundledSyntaxPath + | dir == userSyntaxPlaceholderName -> xdgSyntaxDir + | otherwise -> return dir + + return $ Right $ c { configSyntaxDirs = newDirs } getConfig :: FilePath -> IO (Either String Config) getConfig fp = runExceptT $ do diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -4,20 +4,22 @@ import Prelude.MH import Brick.BChan -import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent ( forkIO, threadDelay ) import qualified Control.Concurrent.STM as STM -import Control.Exception (SomeException, catch) -import Data.Int (Int64) +import Control.Exception ( SomeException, catch ) import qualified Data.HashMap.Strict as HM -import Data.Semigroup (Max(..)) -import Data.Time (UTCTime(..), secondsToDiffTime, getCurrentTime, diffUTCTime) -import Data.Time.Calendar (Day(..)) +import Data.Int (Int64) +import Data.Semigroup ( Max(..) ) +import Data.Time ( UTCTime(..), secondsToDiffTime, getCurrentTime + , diffUTCTime ) +import Data.Time.Calendar ( Day(..) ) -import Network.Mattermost.Types (ChannelId) +import Network.Mattermost.Types ( ChannelId ) import qualified Network.Mattermost.WebSocket as WS import Constants import Types + connectWebsockets :: MH () connectWebsockets = do diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -7,6 +7,7 @@ import Prelude () import Prelude.MH + -- | The number of rows to consider a "page" when scrolling pageAmount :: Int pageAmount = 15 diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -4,14 +4,15 @@ import Brick -import Types -import Draw.Main -import Draw.ShowHelp -import Draw.LeaveChannelConfirm import Draw.DeleteChannelConfirm +import Draw.JoinChannel +import Draw.LeaveChannelConfirm +import Draw.Main import Draw.PostListOverlay +import Draw.ShowHelp import Draw.UserListOverlay -import Draw.JoinChannel +import Types + draw :: ChatState -> [Widget Name] draw st = diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -18,19 +18,22 @@ module Draw.ChannelList (renderChannelList) where +import Prelude () +import Prelude.MH + import Brick import Brick.Widgets.Border import qualified Data.Sequence as Seq import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Text as T -import Draw.Util import Lens.Micro.Platform (Getting, at, non) + +import Draw.Util import State import Themes import Types -import Prelude () -import Prelude.MH + type GroupName = Text diff --git a/src/Draw/DeleteChannelConfirm.hs b/src/Draw/DeleteChannelConfirm.hs --- a/src/Draw/DeleteChannelConfirm.hs +++ b/src/Draw/DeleteChannelConfirm.hs @@ -8,12 +8,13 @@ import Prelude.MH import Brick -import Brick.Widgets.Center import Brick.Widgets.Border +import Brick.Widgets.Center -import Types -import Themes import Draw.Main +import Themes +import Types + drawDeleteChannelConfirm :: ChatState -> [Widget Name] drawDeleteChannelConfirm st = diff --git a/src/Draw/JoinChannel.hs b/src/Draw/JoinChannel.hs --- a/src/Draw/JoinChannel.hs +++ b/src/Draw/JoinChannel.hs @@ -4,23 +4,25 @@ ) where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick -import Brick.Widgets.List -import Brick.Widgets.Center -import Brick.Widgets.Border +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.List import qualified Data.Text as T import qualified Data.Vector as V -import Text.Wrap ( defaultWrapSettings, preserveIndentation ) -import Network.Mattermost.Types (Channel) -import Network.Mattermost.Lenses ( channelDisplayNameL , channelNameL - , channelPurposeL ) +import Text.Wrap ( defaultWrapSettings, preserveIndentation ) -import Types -import Themes -import Draw.Main +import Network.Mattermost.Lenses ( channelDisplayNameL , channelNameL + , channelPurposeL ) +import Network.Mattermost.Types ( Channel ) + +import Draw.Main +import Themes +import Types + drawJoinChannel :: ChatState -> [Widget Name] drawJoinChannel st = (joinBorders $ joinChannelBox st) : (forceAttr "invalid" <$> drawMain st) diff --git a/src/Draw/LeaveChannelConfirm.hs b/src/Draw/LeaveChannelConfirm.hs --- a/src/Draw/LeaveChannelConfirm.hs +++ b/src/Draw/LeaveChannelConfirm.hs @@ -8,12 +8,13 @@ import Prelude.MH import Brick -import Brick.Widgets.Center import Brick.Widgets.Border +import Brick.Widgets.Center -import Types -import Themes import Draw.Main +import Themes +import Types + drawLeaveChannelConfirm :: ChatState -> [Widget Name] drawLeaveChannelConfirm st = diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -7,42 +7,44 @@ import Brick import Brick.Widgets.Border import Brick.Widgets.Border.Style -import Brick.Widgets.Center (hCenter) -import Brick.Widgets.Edit (editContentsL, renderEditor, getEditContents) -import Brick.Widgets.List (renderList) -import Control.Arrow ((>>>)) -import Control.Monad.Trans.Reader (withReaderT) -import Data.Time.Clock (UTCTime(..)) -import Data.Time.Calendar (fromGregorian) +import Brick.Widgets.Center ( hCenter ) +import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents ) +import Brick.Widgets.List ( renderList ) +import Control.Arrow ( (>>>) ) +import Control.Monad.Trans.Reader ( withReaderT ) +import Data.Char ( isSpace, isPunctuation ) +import qualified Data.Foldable as F +import Data.List ( intersperse ) import qualified Data.Sequence as Seq import qualified Data.Set as S -import qualified Data.Foldable as F -import Data.List (intersperse) import qualified Data.Text as T -import Data.Text.Zipper (cursorPosition, insertChar, getText, gotoEOL) -import Data.Char (isSpace, isPunctuation) -import Lens.Micro.Platform ((.~), (^?!), to, view, folding) +import Data.Text.Zipper ( cursorPosition, insertChar, getText, gotoEOL ) +import Data.Time.Calendar ( fromGregorian ) +import Data.Time.Clock ( UTCTime(..) ) +import qualified Graphics.Vty as Vty +import Lens.Micro.Platform ( (.~), (^?!), to, view, folding ) -import Network.Mattermost.Types (ChannelId, Type(Direct), ServerTime(..), UserId) +import Network.Mattermost.Types ( ChannelId, Type(Direct) + , ServerTime(..), UserId ) -import qualified Graphics.Vty as Vty -import Draw.ChannelList (renderChannelList) +import Completion ( Completer(..), CompletionAlternative(..), currentAlternative ) +import Draw.ChannelList ( renderChannelList ) import Draw.Messages import Draw.Util +import Events.Keybindings +import Events.MessageSelect import Markdown -import Completion (Completer(..), currentAlternative) import State import Themes -import TimeUtils (justAfter, justBefore) +import TimeUtils ( justAfter, justBefore ) import Types import Types.KeyEvents -import Events.Keybindings -import Events.MessageSelect -previewFromInput :: UserId -> Text -> Maybe Message -previewFromInput _ s | s == T.singleton cursorSentinel = Nothing -previewFromInput uId s = + +previewFromInput :: Maybe MessageType -> UserId -> Text -> Maybe Message +previewFromInput _ _ s | s == T.singleton cursorSentinel = Nothing +previewFromInput overrideTy uId s = -- If it starts with a slash but not /me, this has no preview -- representation let isCommand = "/" `T.isPrefixOf` s @@ -50,7 +52,7 @@ content = if isEmote then T.stripStart $ T.drop 3 s else s - msgTy = if isEmote then CP Emote else CP NormalPost + msgTy = fromMaybe (if isEmote then CP Emote else CP NormalPost) overrideTy in if isCommand && not isEmote then Nothing else Just $ Message { _mText = getBlocks content @@ -58,8 +60,9 @@ , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0 -- The date is not used for preview -- rendering, but we need to provide one. - -- Ideally we'd just today's date, but the - -- rendering function is pure so we can't. + -- Ideally we'd just use today's date, but + -- the rendering function is pure so we + -- can't. , _mType = msgTy , _mPending = False , _mDeleted = False @@ -217,7 +220,7 @@ renderUserCommandBox st hs = let prompt = txt $ case st^.csEditState.cedEditMode of Replying _ _ -> "reply> " - Editing _ -> "edit> " + Editing _ _ -> "edit> " NewPost -> "> " inputBox = renderEditor (drawEditorContents st hs) True (st^.csEditState.cedEditor) curContents = getEditContents $ st^.csEditState.cedEditor @@ -273,7 +276,7 @@ chnName = chan^.ccInfo.cdName topicStr = chan^.ccInfo.cdHeader userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts - parts = [ u^.uiName + parts = [ userSigil <> u^.uiName , if (all T.null names) then mempty else "is" @@ -416,8 +419,8 @@ newMessagesMsg d = newMessageOfType (T.pack "New Messages") (C NewMessagesTransition) d -renderChannelSelect :: ChatState -> Widget Name -renderChannelSelect st = +renderChannelSelectPrompt :: ChatState -> Widget Name +renderChannelSelectPrompt st = let cstr = st^.csChannelSelectState.channelSelectInput in withDefAttr channelSelectPromptAttr $ (txt "Switch to channel [use ^ and $ to anchor]: ") <+> @@ -489,11 +492,11 @@ drawCompletionAlternatives :: Completer -> Widget Name drawCompletionAlternatives c = let alternatives = intersperse (txt " ") $ mkAlternative <$> toList (completionAlternatives c) - mkAlternative (displayVal, _) = - let format = if displayVal == (fst $ currentAlternative c) + mkAlternative alt = + let format = if completionInput alt == (completionInput $ currentAlternative c) then visible . withDefAttr completionAlternativeCurrentAttr else id - in format $ txt displayVal + in format $ txt $ completionDisplay alt in hBox [ borderElem bsHorizontal , txt "[" , withDefAttr completionAlternativeListAttr $ @@ -532,7 +535,10 @@ curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $ st^.csEditState.cedEditor.editContentsL curStr = T.intercalate "\n" curContents - previewMsg = previewFromInput uId curStr + overrideTy = case st^.csEditState.cedEditMode of + Editing _ ty -> Just ty + _ -> Nothing + previewMsg = previewFromInput overrideTy uId curStr thePreview = let noPreview = str "(No preview)" msgPreview = case previewMsg of Nothing -> noPreview @@ -556,7 +562,7 @@ userInputArea :: ChatState -> HighlightSet -> Widget Name userInputArea st hs = case appMode st of - ChannelSelect -> renderChannelSelect st + ChannelSelect -> renderChannelSelectPrompt st UrlSelect -> hCenter $ hBox [ txt "Press " , withDefAttr clientEmphAttr $ txt "Enter" , txt " to open the selected URL or " diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -2,13 +2,13 @@ import Brick import Brick.Widgets.Border -import Control.Monad.Trans.Reader (withReaderT) +import Control.Monad.Trans.Reader ( withReaderT ) import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ((.~), to) -import Network.Mattermost.Types (ServerTime(..)) +import Lens.Micro.Platform ( (.~), to ) +import Network.Mattermost.Types ( ServerTime(..) ) import Prelude () import Prelude.MH diff --git a/src/Draw/PostListOverlay.hs b/src/Draw/PostListOverlay.hs --- a/src/Draw/PostListOverlay.hs +++ b/src/Draw/PostListOverlay.hs @@ -5,21 +5,22 @@ import Prelude () import Prelude.MH -import Control.Monad.Trans.Reader (withReaderT) +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center +import Control.Monad.Trans.Reader ( withReaderT ) import qualified Data.Text as T -import Lens.Micro.Platform ((^?), (%~), to) -import Network.Mattermost.Types +import Lens.Micro.Platform ( (^?), (%~), to ) + import Network.Mattermost.Lenses +import Network.Mattermost.Types -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Center +import Draw.Main +import Draw.Messages +import Draw.Util +import Themes +import Types -import Themes -import Types -import Draw.Main -import Draw.Messages -import Draw.Util hLimitWithPadding :: Int -> Widget n -> Widget n hLimitWithPadding pad contents = Widget @@ -85,7 +86,7 @@ | Just u <- userByDMChannelName (chan^.ccInfo.cdName) (myUserId st) st -> - (forceAttr channelNameAttr (txt (T.singleton '@' <> u^.uiName)) <=> + (forceAttr channelNameAttr (txt (userSigil <> u^.uiName)) <=> (str " " <+> renderedMsg)) _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to mkChannelName)) <=> (str " " <+> renderedMsg)) diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -1,36 +1,38 @@ module Draw.ShowHelp (drawShowHelp) where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick -import Brick.Themes (themeDescriptions) -import Brick.Widgets.Border -import Brick.Widgets.Center (hCenter, centerLayer) -import Brick.Widgets.List (listSelectedFocusedAttr) +import Brick +import Brick.Themes ( themeDescriptions ) +import Brick.Widgets.Border +import Brick.Widgets.Center ( hCenter, centerLayer ) +import Brick.Widgets.List ( listSelectedFocusedAttr ) import qualified Data.Map as M import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Network.Mattermost.Version (mmApiVersion) -import Themes -import Types -import Types.KeyEvents (Binding(..), ppBinding, nonCharKeys, eventToBinding) -import Events.Keybindings -import Command -import Events.ShowHelp -import Events.ChannelScroll -import Events.ChannelSelect -import Events.UrlSelect -import Events.Main -import Events.MessageSelect -import Events.PostListOverlay -import Events.UserListOverlay -import State.Editing (editingKeybindings) -import Markdown (renderText) -import Options (mhVersion) -import HelpTopics (helpTopics) +import Network.Mattermost.Version ( mmApiVersion ) +import Command +import Events.ChannelScroll +import Events.ChannelSelect +import Events.Keybindings +import Events.Main +import Events.MessageSelect +import Events.PostListOverlay +import Events.ShowHelp +import Events.UrlSelect +import Events.UserListOverlay +import HelpTopics ( helpTopics ) +import Markdown ( renderText ) +import Options ( mhVersion ) +import State.Editing ( editingKeybindings ) +import Themes +import Types +import Types.KeyEvents ( Binding(..), ppBinding, nonCharKeys, eventToBinding ) + + drawShowHelp :: HelpTopic -> ChatState -> [Widget Name] drawShowHelp topic st = [helpBox (helpTopicViewportName topic) $ helpTopicDraw topic st] @@ -41,6 +43,7 @@ MainHelp -> mainHelp (configUserKeys (st^.csResources.crConfiguration)) ScriptHelp -> scriptHelp ThemeHelp -> themeHelp + SyntaxHighlightHelp -> syntaxHighlightHelp (configSyntaxDirs $ st^.csResources.crConfiguration) KeybindingHelp -> keybindingHelp (configUserKeys (st^.csResources.crConfiguration)) mainHelp :: KeyConfig -> Widget Name @@ -212,6 +215,30 @@ , "." ] ] + +para :: Text -> Widget a +para t = padTop (Pad 1) $ hCenter (hLimit 72 $ padRight Max $ renderText t) + +syntaxHighlightHelp :: [FilePath] -> Widget a +syntaxHighlightHelp dirs = overrideAttr codeAttr helpEmphAttr $ vBox + [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "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 $ "```" + , para $ "The possible values of `language` are determined by the available syntax " <> + "definitions. The available definitions are loaded from the following " <> + "directories according to the configuration setting `syntaxDirectories`. " <> + "If the setting is omitted, it defaults to the following sequence of directories:" + , para $ T.pack $ intercalate "\n" $ (\d -> "`" <> d <> "`") <$> dirs + , para $ "Syntax definitions are in the Kate XML format. Files with an " <> + "`xml` extension are loaded from each directory, with directories earlier " <> + "in the list taking precedence over later directories when more than one " <> + "directory provides a definition file for the same syntax." + , para $ "To place custom definitions in a directory, place a Kate " <> + "XML syntax definition in the directory and ensure that a copy of " <> + "`language.dtd` is also present. The file `language.dtd` can be found in " <> + "the `syntax/` directory of your Matterhorn distribution." + ] themeHelp :: Widget a themeHelp = overrideAttr codeAttr helpEmphAttr $ vBox diff --git a/src/Draw/UserListOverlay.hs b/src/Draw/UserListOverlay.hs --- a/src/Draw/UserListOverlay.hs +++ b/src/Draw/UserListOverlay.hs @@ -6,22 +6,22 @@ import Prelude () import Prelude.MH -import Control.Monad.Trans.Reader (withReaderT) +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.Edit +import qualified Brick.Widgets.List as L +import Control.Monad.Trans.Reader ( withReaderT ) import qualified Data.Foldable as F import qualified Data.Text as T import qualified Graphics.Vty as V -import Lens.Micro.Platform ((%~)) +import Lens.Micro.Platform ( (%~) ) -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Edit -import qualified Brick.Widgets.List as L -import Brick.Widgets.Center +import Draw.Main +import Draw.Util ( userSigilFromInfo ) +import Themes +import Types -import Themes -import Types -import Draw.Main -import Draw.Util (userSigilFromInfo) hLimitWithPadding :: Int -> Widget n -> Widget n hLimitWithPadding pad contents = Widget diff --git a/src/Draw/Util.hs b/src/Draw/Util.hs --- a/src/Draw/Util.hs +++ b/src/Draw/Util.hs @@ -1,17 +1,18 @@ module Draw.Util where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick -import qualified Data.Text as T +import Brick import qualified Data.Set as Set -import Lens.Micro.Platform (to) -import Network.Mattermost.Types +import qualified Data.Text as T +import Lens.Micro.Platform ( to ) +import Network.Mattermost.Types -import Types -import TimeUtils -import Themes +import Themes +import TimeUtils +import Types + defaultTimeFormat :: Text defaultTimeFormat = "%R" diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -6,36 +6,38 @@ import Brick import qualified Data.Map as M -import qualified Data.Set as Set import qualified Data.Sequence as Seq +import qualified Data.Set as Set import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ((.=)) +import Lens.Micro.Platform ( (.=) ) -import Network.Mattermost.Types +import Network.Mattermost.Exceptions ( mattermostErrorMessage ) import Network.Mattermost.Lenses +import Network.Mattermost.Types import Network.Mattermost.WebSocket -import Network.Mattermost.Exceptions (mattermostErrorMessage) import Connection +import HelpTopics import State import State.Common import Types import Types.KeyEvents -import Events.Keybindings -import Events.ShowHelp -import Events.Main -import Events.JoinChannel import Events.ChannelScroll import Events.ChannelSelect -import Events.LeaveChannelConfirm import Events.DeleteChannelConfirm -import Events.UrlSelect +import Events.JoinChannel +import Events.Keybindings +import Events.LeaveChannelConfirm +import Events.Main import Events.MessageSelect import Events.PostListOverlay +import Events.ShowHelp +import Events.UrlSelect import Events.UserListOverlay + onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState) onEvent st ev = runMHEvent st (onEv >> fetchVisibleIfNeeded) where onEv = do case ev of @@ -60,23 +62,47 @@ onAppEvent (WSEvent we) = handleWSEvent we onAppEvent (RespEvent f) = f -onAppEvent (AsyncMattermostError e) = do - mhError $ mattermostErrorMessage e -onAppEvent (AsyncErrEvent e) = do - let msg = "An unexpected error has occurred! The exception encountered was:\n " <> - T.pack (show e) <> - "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" - mhError msg onAppEvent (WebsocketParseError e) = do let msg = "A websocket message could not be parsed:\n " <> T.pack e <> "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" - mhError msg + mhError $ GenericError msg onAppEvent (IEvent e) = do handleIEvent e handleIEvent :: InternalEvent -> MH () -handleIEvent (DisplayError msg) = postErrorMessage' msg +handleIEvent (DisplayError e) = postErrorMessage' $ formatError e + +formatError :: MHError -> T.Text +formatError (GenericError msg) = + msg +formatError (NoSuchChannel chan) = + T.pack $ "No such channel: " <> show chan +formatError (NoSuchUser user) = + T.pack $ "No such user: " <> show user +formatError (AmbiguousName name) = + (T.pack $ "The input " <> show name <> " matches both channels ") <> + "and users. Try using '" <> userSigil <> "' or '" <> + normalChannelSigil <> "' to disambiguate." +formatError (ServerError e) = + mattermostErrorMessage e +formatError (ClipboardError msg) = + msg +formatError (ConfigOptionMissing opt) = + T.pack $ "Config option " <> show opt <> " missing" +formatError (ProgramExecutionFailed progName logPath) = + T.pack $ "An error occurred when running " <> show progName <> + "; see " <> show logPath <> " for details." +formatError (NoSuchScript name) = + "No script named " <> name <> " was found" +formatError (NoSuchHelpTopic topic) = + let knownTopics = (" - " <>) <$> helpTopicName <$> helpTopics + in "Unknown help topic: `" <> topic <> "`. " <> + (T.unlines $ "Available topics are:" : knownTopics) +formatError (AsyncErrEvent e) = + "An unexpected error has occurred! The exception encountered was:\n " <> + T.pack (show e) <> + "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" onVtyEvent :: Vty.Event -> MH () onVtyEvent e = do diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -1,14 +1,15 @@ module Events.ChannelScroll where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick +import Brick import qualified Graphics.Vty as Vty -import Types -import Events.Keybindings -import State +import Events.Keybindings +import State +import Types + channelScrollKeybindings :: KeyConfig -> [Keybinding] channelScrollKeybindings = mkKeybindings diff --git a/src/Events/ChannelSelect.hs b/src/Events/ChannelSelect.hs --- a/src/Events/ChannelSelect.hs +++ b/src/Events/ChannelSelect.hs @@ -1,15 +1,16 @@ module Events.ChannelSelect where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ((%=)) +import Lens.Micro.Platform ( (%=) ) -import Events.Keybindings -import Types -import State +import Events.Keybindings +import State +import Types + onEventChannelSelect :: Vty.Event -> MH () onEventChannelSelect = diff --git a/src/Events/DeleteChannelConfirm.hs b/src/Events/DeleteChannelConfirm.hs --- a/src/Events/DeleteChannelConfirm.hs +++ b/src/Events/DeleteChannelConfirm.hs @@ -1,12 +1,13 @@ module Events.DeleteChannelConfirm where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import qualified Graphics.Vty as Vty -import Types -import State +import Types +import State + onEventDeleteChannelConfirm :: Vty.Event -> MH () onEventDeleteChannelConfirm (Vty.EvKey k []) = do diff --git a/src/Events/JoinChannel.hs b/src/Events/JoinChannel.hs --- a/src/Events/JoinChannel.hs +++ b/src/Events/JoinChannel.hs @@ -1,16 +1,17 @@ module Events.JoinChannel where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick.Widgets.List +import Brick.Widgets.List import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ((.=)) +import Lens.Micro.Platform ( (.=) ) -import Network.Mattermost.Types (getId) +import Network.Mattermost.Types ( getId ) -import Types -import State (joinChannel) +import State ( joinChannel ) +import Types + joinChannelListKeys :: [Vty.Key] joinChannelListKeys = diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -18,15 +18,18 @@ , keyEventName , keyEventFromName - ) where + ) +where +import Prelude () +import Prelude.MH + import qualified Data.Map.Strict as M import qualified Graphics.Vty as Vty import Types import Types.KeyEvents -import Prelude () -import Prelude.MH + -- * Keybindings diff --git a/src/Events/LeaveChannelConfirm.hs b/src/Events/LeaveChannelConfirm.hs --- a/src/Events/LeaveChannelConfirm.hs +++ b/src/Events/LeaveChannelConfirm.hs @@ -1,12 +1,13 @@ module Events.LeaveChannelConfirm where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import qualified Graphics.Vty as Vty -import Types -import State +import State +import Types + onEventLeaveChannelConfirm :: Vty.Event -> MH () onEventLeaveChannelConfirm (Vty.EvKey k []) = do diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -1,31 +1,34 @@ {-# LANGUAGE MultiWayIf #-} module Events.Main where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick hiding (Direction) -import Brick.Widgets.Edit +import Brick hiding ( Direction ) +import Brick.Widgets.Edit +import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ((%=), (.=), to, at) +import Lens.Micro.Platform ( (%=), (.=), to, at ) +import qualified Skylighting.Types as Sky -import Types -import Events.Keybindings -import State -import State.PostListOverlay (enterFlaggedPostListMode) -import State.Editing -import Command -import Completion -import InputHistory -import HelpTopics (mainHelpTopic) -import Constants +import Network.Mattermost.Types ( Type(..) ) -import Network.Mattermost.Types (Type(..)) +import Command +import Completion +import Constants +import Events.Keybindings +import HelpTopics ( mainHelpTopic ) +import InputHistory +import State +import State.Editing +import State.PostListOverlay ( enterFlaggedPostListMode ) +import Types + onEventMain :: Vty.Event -> MH () onEventMain = handleKeyboardEvent mainKeybindings $ \ ev -> case ev of @@ -183,7 +186,9 @@ ch <- channelByName cname st case ch^.ccInfo.cdType of Group -> Nothing - _ -> Just [dupe cname, dupe $ normalChannelSigil <> cname] + _ -> Just [ CompletionAlternative cname (normalChannelSigil <> cname) cname + , mkAlt $ normalChannelSigil <> cname + ] ) userCompletions = concat $ catMaybes (flip map allUIds $ \uId -> @@ -193,13 +198,18 @@ Just u | u^.uiDeleted -> Nothing Just u -> let mNick = case u^.uiNickName of - Just nick | displayNick -> [(userSigil <> nick, userSigil <> u^.uiName), (nick, u^.uiName)] + Just nick | displayNick -> + [ CompletionAlternative (userSigil <> nick) (userSigil <> u^.uiName) (userSigil <> nick) + , CompletionAlternative nick (userSigil <> u^.uiName) nick + ] _ -> [] - in Just $ [dupe $ u^.uiName, dupe $ userSigil <> u^.uiName] <> mNick + in Just $ [ CompletionAlternative (u^.uiName) (userSigil <> u^.uiName) (u^.uiName) + , mkAlt $ userSigil <> u^.uiName + ] <> mNick ) - commandCompletions = dupe <$> map ("/" <>) (commandName <$> commandList) - dupe a = (a, a) + commandCompletions = mkAlt <$> map ("/" <>) (commandName <$> commandList) + mkAlt a = CompletionAlternative a a a completions = Set.fromList (userCompletions ++ channelCompletions ++ commandCompletions) @@ -217,7 +227,12 @@ -- There is no completion in progress, so start a new -- completion from the current input. let line = Z.currentLine $ st^.csEditState.cedEditor.editContentsL - case wordComplete completions line of + completionsToUse = + if | "```" `T.isPrefixOf` line -> + Set.fromList $ (\k -> (CompletionAlternative ("```" <> k) ("```" <> k) k)) <$> + (Sky.sShortname <$> (M.elems $ st^.csResources.crSyntaxMap)) + | otherwise -> completions + case wordComplete completionsToUse line of Nothing -> -- No matches were found, so do nothing. return () @@ -237,5 +252,5 @@ case mComp of Nothing -> return () Just comp -> do - let replacement = snd $ currentAlternative comp + let replacement = completionReplacement $ currentAlternative comp csEditState.cedEditor %= applyEdit (Z.insertMany replacement . Z.deletePrevWord) diff --git a/src/Events/MessageSelect.hs b/src/Events/MessageSelect.hs --- a/src/Events/MessageSelect.hs +++ b/src/Events/MessageSelect.hs @@ -1,15 +1,16 @@ module Events.MessageSelect where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Types -import Events.Keybindings -import State +import Events.Keybindings +import State +import Types + messagesPerPageOperation :: Int messagesPerPageOperation = 10 @@ -47,7 +48,7 @@ beginReplyCompose , mkKb EditMessageEvent "Begin editing the selected message" - beginUpdateMessage + beginEditMessage , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)" beginConfirmDeleteSelectedMessage diff --git a/src/Events/PostListOverlay.hs b/src/Events/PostListOverlay.hs --- a/src/Events/PostListOverlay.hs +++ b/src/Events/PostListOverlay.hs @@ -1,12 +1,14 @@ module Events.PostListOverlay where -import qualified Graphics.Vty as Vty import Prelude () import Prelude.MH -import Types -import Events.Keybindings -import State.PostListOverlay +import qualified Graphics.Vty as Vty + +import Types +import Events.Keybindings +import State.PostListOverlay + onEventPostListOverlay :: Vty.Event -> MH () onEventPostListOverlay = diff --git a/src/Events/ShowHelp.hs b/src/Events/ShowHelp.hs --- a/src/Events/ShowHelp.hs +++ b/src/Events/ShowHelp.hs @@ -1,14 +1,15 @@ module Events.ShowHelp where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick +import Brick import qualified Graphics.Vty as Vty -import Types -import Events.Keybindings -import Constants +import Constants +import Events.Keybindings +import Types + onEventShowHelp :: Vty.Event -> MH () onEventShowHelp = diff --git a/src/Events/UrlSelect.hs b/src/Events/UrlSelect.hs --- a/src/Events/UrlSelect.hs +++ b/src/Events/UrlSelect.hs @@ -1,14 +1,15 @@ module Events.UrlSelect where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick.Widgets.List +import Brick.Widgets.List import qualified Graphics.Vty as Vty -import Types -import Events.Keybindings -import State +import Events.Keybindings +import State +import Types + onEventUrlSelect :: Vty.Event -> MH () onEventUrlSelect = diff --git a/src/Events/UserListOverlay.hs b/src/Events/UserListOverlay.hs --- a/src/Events/UserListOverlay.hs +++ b/src/Events/UserListOverlay.hs @@ -1,14 +1,15 @@ module Events.UserListOverlay where -import qualified Graphics.Vty as Vty import Prelude () import Prelude.MH -import Brick.Widgets.Edit (handleEditorEvent) +import Brick.Widgets.Edit ( handleEditorEvent ) +import qualified Graphics.Vty as Vty -import Types -import Events.Keybindings -import State.UserListOverlay +import Events.Keybindings +import State.UserListOverlay +import Types + onEventUserListOverlay :: Vty.Event -> MH () onEventUserListOverlay = diff --git a/src/FilePaths.hs b/src/FilePaths.hs --- a/src/FilePaths.hs +++ b/src/FilePaths.hs @@ -10,25 +10,32 @@ , xdgName , locateConfig + , xdgSyntaxDir + , syntaxDirName , Script(..) , locateScriptPath , getAllScripts - ) where + ) +where import Prelude () import Prelude.MH -import Data.Text (unpack) +import Data.Text ( unpack ) import System.Directory ( doesFileExist , doesDirectoryExist , getDirectoryContents , getPermissions , executable ) -import System.Environment.XDG.BaseDir (getUserConfigFile, getAllConfigFiles) -import System.FilePath (takeBaseName) +import System.Environment.XDG.BaseDir ( getUserConfigFile + , getAllConfigFiles + , getUserConfigDir + ) +import System.FilePath ( (), takeBaseName ) + xdgName :: String xdgName = "matterhorn" @@ -48,11 +55,19 @@ lastRunStateFilePath teamId = getUserConfigFile xdgName (lastRunStateFileName teamId) +-- | Get the XDG path to the user-specific syntax definition directory. +-- The path does not necessarily exist. +xdgSyntaxDir :: IO FilePath +xdgSyntaxDir = ( syntaxDirName) <$> getUserConfigDir xdgName + +syntaxDirName :: FilePath +syntaxDirName = "syntax" + -- | Find a specified configuration file by looking in all of the -- supported locations. locateConfig :: FilePath -> IO (Maybe FilePath) locateConfig filename = do - xdgLocations <- getAllConfigFiles "matterhorn" filename + xdgLocations <- getAllConfigFiles xdgName filename let confLocations = ["./" <> filename] ++ xdgLocations ++ ["/etc/matterhorn/" <> filename] @@ -84,7 +99,7 @@ locateScriptPath name | head name == '.' = return ScriptNotFound | otherwise = do - xdgLocations <- getAllConfigFiles "matterhorn" scriptDirName + xdgLocations <- getAllConfigFiles xdgName scriptDirName let cmdLocations = [ xdgLoc ++ "/" ++ name | xdgLoc <- xdgLocations ] ++ [ "/etc/matterhorn/scripts/" <> name ] @@ -98,7 +113,7 @@ -- scripts. getAllScripts :: IO ([FilePath], [FilePath]) getAllScripts = do - xdgLocations <- getAllConfigFiles "matterhorn" scriptDirName + xdgLocations <- getAllConfigFiles xdgName scriptDirName let cmdLocations = xdgLocations ++ ["/etc/matterhorn/scripts"] let getCommands dir = do exists <- doesDirectoryExist dir diff --git a/src/HelpTopics.hs b/src/HelpTopics.hs --- a/src/HelpTopics.hs +++ b/src/HelpTopics.hs @@ -3,7 +3,6 @@ ( helpTopics , lookupHelpTopic , themeHelpTopic - , mainHelpTopic ) where @@ -13,12 +12,14 @@ import Types + helpTopics :: [HelpTopic] helpTopics = [ mainHelpTopic , scriptHelpTopic , themeHelpTopic , keybindingHelpTopic + , syntaxHighlightingHelpTopic ] mainHelpTopic :: HelpTopic @@ -37,6 +38,11 @@ keybindingHelpTopic = HelpTopic "keybindings" "Help on overriding keybindings" KeybindingHelp KeybindingHelpText + +syntaxHighlightingHelpTopic :: HelpTopic +syntaxHighlightingHelpTopic = + HelpTopic "syntax" "Help on syntax highlighing" + SyntaxHighlightHelp SyntaxHighlightHelpText lookupHelpTopic :: Text -> Maybe HelpTopic lookupHelpTopic topic = diff --git a/src/IOUtil.hs b/src/IOUtil.hs --- a/src/IOUtil.hs +++ b/src/IOUtil.hs @@ -1,13 +1,15 @@ module IOUtil ( convertIOException - ) where + ) +where import Prelude () import Prelude.MH import Control.Exception import Control.Monad.Trans.Except -import System.IO.Error (ioeGetErrorString) +import System.IO.Error ( ioeGetErrorString ) + convertIOException :: IO a -> ExceptT String IO a convertIOException act = do diff --git a/src/InputHistory.hs b/src/InputHistory.hs --- a/src/InputHistory.hs +++ b/src/InputHistory.hs @@ -7,24 +7,27 @@ , addHistoryEntry , getHistoryEntry , removeChannelHistory - ) where + ) +where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Control.Monad.Trans.Except -import Lens.Micro.Platform ((.~), (^?), (%~), at, ix, makeLenses) +import Control.Monad.Trans.Except import qualified Data.HashMap.Strict as HM -import System.Directory (createDirectoryIfMissing) -import System.FilePath (dropFileName) -import qualified System.IO.Strict as S import qualified Data.Vector as V +import Lens.Micro.Platform ( (.~), (^?), (%~), at, ix, makeLenses ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( dropFileName ) +import qualified System.IO.Strict as S import qualified System.Posix.Files as P import qualified System.Posix.Types as P -import IOUtil -import FilePaths -import Network.Mattermost.Types (ChannelId) +import Network.Mattermost.Types ( ChannelId ) + +import FilePaths +import IOUtil + data InputHistory = InputHistory { _historyEntries :: HashMap ChannelId (V.Vector Text) diff --git a/src/LastRunState.hs b/src/LastRunState.hs --- a/src/LastRunState.hs +++ b/src/LastRunState.hs @@ -8,26 +8,29 @@ , writeLastRunState , readLastRunState , isValidLastRunState - ) where + ) +where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Control.Monad.Trans.Except +import Control.Monad.Trans.Except import qualified Data.Aeson as A import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import Lens.Micro.Platform (makeLenses) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (dropFileName) +import Lens.Micro.Platform ( makeLenses ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( dropFileName ) import qualified System.Posix.Files as P import qualified System.Posix.Types as P -import IOUtil -import FilePaths -import Network.Mattermost.Types -import Network.Mattermost.Lenses -import Types +import Network.Mattermost.Lenses +import Network.Mattermost.Types + +import FilePaths +import IOUtil +import Types + -- | Run state of the program. This is saved in a file on program exit and -- | looked up from the file on program startup. diff --git a/src/Login.hs b/src/Login.hs --- a/src/Login.hs +++ b/src/Login.hs @@ -3,29 +3,32 @@ {-# LANGUAGE RankNTypes #-} module Login ( interactiveGatherCredentials - ) where + ) +where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick -import Brick.Forms -import Brick.Focus -import Brick.Widgets.Edit -import Brick.Widgets.Center -import Brick.Widgets.Border -import Lens.Micro.Platform ((.~), Lens', makeLenses) +import Brick +import Brick.Focus +import Brick.Forms +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.Edit import qualified Data.Text as T -import Graphics.Vty -import System.Exit (exitSuccess) +import Graphics.Vty +import Lens.Micro.Platform ( (.~), Lens', makeLenses ) +import System.Exit ( exitSuccess ) import qualified System.IO.Error as Err -import Network.Mattermost.Exceptions (LoginFailureException(..)) +import Network.Mattermost.Exceptions ( LoginFailureException(..) ) -import Markdown -import Types ( ConnectionInfo(..), ciPassword, ciUsername, ciHostname - , ciPort, AuthenticationException(..) - ) +import Markdown +import Types ( ConnectionInfo(..) + , ciPassword, ciUsername, ciHostname + , ciPort, AuthenticationException(..) + ) + data Name = Hostname | Port | Username | Password deriving (Ord, Eq, Show) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,14 +1,15 @@ module Main where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import System.Exit (exitFailure) +import System.Exit ( exitFailure ) -import Config -import Options -import App -import Events (ensureKeybindingConsistency) +import Config +import Options +import App +import Events ( ensureKeybindingConsistency ) + main :: IO () main = do diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -16,21 +16,20 @@ ) where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import Brick ( (<+>), Widget, textWidth ) +import qualified Brick as B import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border.Style as B import qualified Brick.Widgets.Skylighting as BS -import qualified Brick as B +import qualified Cheapskate as C import Cheapskate.Types ( Block , Blocks , Inlines , ListType ) -import qualified Cheapskate as C -import qualified Data.Text as T import qualified Data.Foldable as F import Data.Monoid (First(..)) import Data.Sequence ( ViewL(..) @@ -40,19 +39,22 @@ , viewl , viewr) import qualified Data.Sequence as S -import qualified Skylighting as Sky 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 Network.Mattermost.Lenses ( postEditAtL, postCreateAtL ) +import Network.Mattermost.Types ( ServerTime(..) ) + import Themes -import Types (HighlightSet(..), userSigil, normalChannelSigil) +import Types ( HighlightSet(..), userSigil, normalChannelSigil ) import Types.Posts import Types.Messages + emptyHSet :: HighlightSet -emptyHSet = HighlightSet Set.empty Set.empty +emptyHSet = HighlightSet Set.empty Set.empty mempty omitUsernameTypes :: [MessageType] omitUsernameTypes = @@ -273,9 +275,9 @@ blockToWidget hSet (C.Blockquote is) = addQuoting (vBox $ fmap (blockToWidget hSet) is) blockToWidget hSet (C.List _ l bs) = blocksToList l bs hSet -blockToWidget _ (C.CodeBlock ci tx) = - let f = maybe rawCodeBlockToWidget codeBlockToWidget mSyntax - mSyntax = Sky.lookupSyntax (C.codeLang ci) Sky.defaultSyntaxMap +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 _ (C.HtmlBlock txt) = textWithCursor txt blockToWidget _ (C.HRule) = B.vLimit 1 (B.fill '*') @@ -296,10 +298,10 @@ , B.Widget B.Fixed B.Fixed $ return childResult ] -codeBlockToWidget :: Sky.Syntax -> Text -> Widget a -codeBlockToWidget syntax tx = +codeBlockToWidget :: Sky.SyntaxMap -> Sky.Syntax -> Text -> Widget a +codeBlockToWidget syntaxMap syntax tx = let result = Sky.tokenize cfg syntax tx - cfg = Sky.TokenizerConfig Sky.defaultSyntaxMap False + cfg = Sky.TokenizerConfig syntaxMap False in case result of Left _ -> rawCodeBlockToWidget tx Right tokLines -> @@ -428,8 +430,7 @@ gatherStrings s n rs = let s' = removeCursor s in case viewl rs of - _ | s' `Set.member` uSet || - (userSigil `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` uSet)) -> + _ | (userSigil `T.isPrefixOf` s' && (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 @@ -447,8 +448,6 @@ ":" `T.isSuffixOf` s' && textWidth s' > 2 -> Fragment (TStr s) Emoji - | removeCursor s' `Set.member` uSet -> - Fragment (TStr s) (User s) | Just uname <- userSigil `T.stripPrefix` removeCursor s , removeCursor uname `Set.member` uSet -> Fragment (TStr s) (User uname) diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -5,13 +5,14 @@ import Prelude () import Prelude.MH -import Data.Version (showVersion) +import Data.Version ( showVersion ) import Development.GitRev -import Network.Mattermost.Version (mmApiVersion) -import Paths_matterhorn (version) +import Network.Mattermost.Version ( mmApiVersion ) +import Paths_matterhorn ( version ) import System.Console.GetOpt -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + data Behaviour = Normal diff --git a/src/Prelude/MH.hs b/src/Prelude/MH.hs --- a/src/Prelude/MH.hs +++ b/src/Prelude/MH.hs @@ -56,29 +56,30 @@ , Time.UTCTime , Time.TimeZoneSeries , Time.NominalDiffTime -) where +) +where #if !MIN_VERSION_base(4,11,0) -import Data.Semigroup ((<>)) +import Data.Semigroup ( (<>) ) #endif -import qualified Prelude.Compat as P -import Prelude.Compat -import Control.Applicative ((<|>)) + +import Control.Applicative ( (<|>) ) import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as Monad import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.Maybe as Maybe +import qualified Data.Time as Time +import qualified Data.Time.LocalTime.TimeZone.Series as Time import qualified GHC.Exts as Exts -import qualified Text.Read as Read import qualified Lens.Micro.Platform as Lens +import Prelude.Compat +import qualified Prelude.Compat as P +import qualified Text.Read as Read -- these below we import only for type aliases -import Data.Text (Text) -import Data.HashMap.Strict (HashMap) -import Data.Sequence (Seq) -import Data.Set (Set) - -import qualified Data.Time as Time -import qualified Data.Time.LocalTime.TimeZone.Series as Time +import Data.HashMap.Strict ( HashMap ) +import Data.Sequence ( Seq ) +import Data.Set ( Set ) +import Data.Text ( Text ) diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -4,18 +4,20 @@ ) where -import qualified Data.Text as T -import Control.Concurrent (takeMVar, newEmptyMVar) +import Prelude () +import Prelude.MH + +import Control.Concurrent ( takeMVar, newEmptyMVar ) import qualified Control.Concurrent.STM as STM -import System.Exit (ExitCode(..)) -import Prelude () -import Prelude.MH +import qualified Data.Text as T +import System.Exit ( ExitCode(..) ) -import Types -import State (sendMessage, runLoggedCommand) -import State.Common -import FilePaths (Script(..), getAllScripts, locateScriptPath) +import FilePaths ( Script(..), getAllScripts, locateScriptPath ) +import State ( sendMessage, runLoggedCommand ) +import State.Common +import Types + findAndRunScript :: Text -> Text -> MH () findAndRunScript scriptName input = do fpMb <- liftIO $ locateScriptPath (T.unpack scriptName) @@ -30,10 +32,9 @@ "$ chmod u+x " <> T.pack scriptPath <> "\n" <> "```\n" <> "to correct this error. " <> scriptHelpAddendum) - mhError msg + mhError $ GenericError msg ScriptNotFound -> do - let msg = ("No script named " <> scriptName <> " was found") - mhError msg + mhError $ NoSuchScript scriptName runScript :: STM.TChan ProgramOutput -> FilePath -> Text -> IO (MH ()) runScript outputChan fp text = do @@ -68,7 +69,7 @@ mconcat [ " - " <> T.pack cmd <> "\n" | cmd <- nonexecs ] <> "\n" <> scriptHelpAddendum) - mhError errMsg + mhError $ GenericError errMsg scriptHelpAddendum :: Text scriptHelpAddendum = diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -88,7 +88,7 @@ , messageSelectDownBy , deleteSelectedMessage , beginReplyCompose - , beginUpdateMessage + , beginEditMessage , getSelectedMessage , cancelReplyOrEdit , replyToLatestMessage @@ -110,58 +110,59 @@ import Prelude () import Prelude.MH -import Brick (invalidateCacheEntry) -import Brick.Themes (themeToAttrMap) -import Brick.Widgets.Edit (getEditContents, editContentsL) -import Brick.Widgets.List (list, listMoveTo, listSelectedElement) -import Control.Concurrent.Async (runConcurrently, Concurrently(..), concurrently) -import Control.Concurrent (MVar, putMVar, forkIO) +import Brick ( invalidateCacheEntry ) +import Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd ) +import Brick.Themes ( themeToAttrMap ) +import Brick.Widgets.Edit ( applyEdit ) +import Brick.Widgets.Edit ( getEditContents, editContentsL ) +import Brick.Widgets.List ( list, listMoveTo, listSelectedElement ) +import Control.Concurrent ( MVar, putMVar, forkIO ) +import Control.Concurrent.Async ( runConcurrently, Concurrently(..), concurrently ) import qualified Control.Concurrent.STM as STM -import Control.Exception (SomeException, try) -import Data.Char (isAlphaNum) -import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd) -import Brick.Widgets.Edit (applyEdit) +import Control.Exception ( SomeException, try ) import qualified Data.ByteString as BS -import Data.Function (on) -import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL) +import Data.Char ( isAlphaNum ) +import Data.Function ( on ) import qualified Data.HashMap.Strict as HM +import Data.List ( findIndex ) +import Data.Maybe ( fromJust ) import qualified Data.Sequence as Seq -import Data.List (findIndex) -import Data.Maybe (fromJust) import qualified Data.Set as Set import qualified Data.Text as T -import Data.Time (getCurrentTime) +import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL ) +import Data.Time ( getCurrentTime ) import qualified Data.Vector as V -import Graphics.Vty (outputIface) -import Graphics.Vty.Output.Interface (ringTerminalBell) +import Graphics.Vty ( outputIface ) +import Graphics.Vty.Output.Interface ( ringTerminalBell ) import Lens.Micro.Platform -import System.Exit (ExitCode(..)) -import System.Process (proc, std_in, std_out, std_err, StdStream(..), - createProcess, waitForProcess) -import System.IO (hGetContents, hFlush, hPutStrLn) -import System.Directory (createDirectoryIfMissing) -import System.Environment.XDG.BaseDir (getUserCacheDir) +import System.Directory ( createDirectoryIfMissing ) +import System.Environment.XDG.BaseDir ( getUserCacheDir ) +import System.Exit ( ExitCode(..) ) import System.FilePath +import System.IO ( hGetContents, hFlush, hPutStrLn ) +import System.Process ( proc, std_in, std_out, std_err, StdStream(..) + , createProcess, waitForProcess ) import qualified Network.Mattermost.Endpoints as MM -import Network.Mattermost.Types import Network.Mattermost.Lenses +import Network.Mattermost.Types import Config +import Constants import FilePaths -import TimeUtils (justBefore, justAfter) -import Types import InputHistory +import Markdown ( blockGetURLs, findVerbatimChunk ) import Themes -import Zipper (Zipper) +import TimeUtils ( justBefore, justAfter ) +import Types +import Zipper ( Zipper ) import qualified Zipper as Z -import Constants -import Markdown (blockGetURLs, findVerbatimChunk) import State.Common import State.Messages -import State.Setup.Threads (updateUserStatuses) +import State.Setup.Threads ( updateUserStatuses ) + -- * Refreshing Channel Data -- | Refresh information about a specific channel. The channel @@ -206,7 +207,7 @@ findUserIds (n:ns) = do case userByUsername n st of Nothing -> do - mhError $ "No such user: " <> n + mhError $ NoSuchUser n return [] Just u -> (u^.uiId:) <$> findUserIds ns @@ -424,7 +425,7 @@ let chType = chan^.ccInfo.cdType if chType /= Direct then setMode DeleteChannelConfirm - else mhError "Direct message channels cannot be deleted." + else mhError $ GenericError "Direct message channels cannot be deleted." deleteCurrentChannel :: MH () deleteCurrentChannel = do @@ -459,18 +460,37 @@ flagMessage pId (not (msg^.mFlagged)) _ -> return () -beginUpdateMessage :: MH () -beginUpdateMessage = do +beginEditMessage :: MH () +beginEditMessage = do selected <- use (to getSelectedMessage) st <- use id case selected of Just msg | isMine st msg && isEditable msg -> do let Just p = msg^.mOriginalPost setMode Main - csEditState.cedEditMode .= Editing p - csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany $ postMessage p)) + csEditState.cedEditMode .= Editing p (msg^.mType) + -- If the post that we're editing is an emote, we need + -- to strip the formatting because that's only there to + -- indicate that the post is an emote. This is annoying and + -- can go away one day when there is an actual post type + -- value of "emote" that we can look at. Note that the + -- removed formatting needs to be reinstated just prior to + -- issuing the API call to update the post. + let toEdit = if msg^.mType == CP Emote + then removeEmoteFormatting $ postMessage p + else postMessage p + csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit)) _ -> return () +removeEmoteFormatting :: T.Text -> T.Text +removeEmoteFormatting t + | "*" `T.isPrefixOf` t && + "*" `T.isSuffixOf` t = T.init $ T.drop 1 t + | otherwise = t + +addEmoteFormatting :: T.Text -> T.Text +addEmoteFormatting t = "*" <> t <> "*" + replyToLatestMessage :: MH () replyToLatestMessage = do msgs <- use (csCurrentChannel . ccContents . cdMessages) @@ -519,7 +539,7 @@ doAsyncWith Preempt $ do result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session return $ case result of - Left (_::SomeException) -> mhError $ T.pack $ "No such channel: " <> (show rawName) + Left (_::SomeException) -> mhError $ NoSuchChannel rawName Right chan -> joinChannel $ getId chan startJoinChannel :: MH () @@ -546,12 +566,19 @@ setMode JoinChannel csJoinChannelList .= Nothing +-- | If the user is not a member of the specified channel, submit a +-- request to join it. Otherwise switch to the channel. joinChannel :: ChannelId -> MH () joinChannel chanId = do setMode Main - myId <- gets myUserId - let member = MinChannelMember myId chanId - doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP + mChan <- preuse (csChannel(chanId)) + case mChan of + Just _ -> setFocus chanId + Nothing -> do + myId <- gets myUserId + let member = MinChannelMember myId chanId + csLastJoinRequest .= Just chanId + doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP -- | When another user adds us to a channel, we need to fetch the -- channel info for that channel. @@ -576,7 +603,7 @@ tryMM (void $ MM.mmAddUser cId channelMember session) (const $ return (return ())) _ -> do - mhError ("No such user: " <> uname) + mhError $ NoSuchUser uname removeUserFromCurrentChannel :: Text -> MH () removeUserFromCurrentChannel uname = do @@ -590,14 +617,14 @@ tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session) (const $ return (return ())) _ -> do - mhError ("No such user: " <> uname) + mhError $ NoSuchUser uname startLeaveCurrentChannel :: MH () startLeaveCurrentChannel = do cInfo <- use (csCurrentChannel.ccInfo) case canLeaveChannel cInfo of True -> setMode LeaveChannelConfirm - False -> mhError "The /leave command cannot be used with this channel." + False -> mhError $ GenericError "The /leave command cannot be used with this channel." leaveCurrentChannel :: MH () leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel @@ -1072,8 +1099,7 @@ changeChannel name = do result <- gets (channelIdByName name) user <- gets (userByUsername name) - let err = mhError $ T.pack $ "The input " <> show name <> " matches both channels " <> - "and users. Try using '@' or '~' to disambiguate." + let err = mhError $ AmbiguousName name case result of (Nothing, Nothing) @@ -1081,7 +1107,7 @@ -- channel, so create one. | Just _ <- user -> attemptCreateDMChannel name -- There were no matches of any kind. - | otherwise -> mhError $ T.pack $ "No such channel: " <> show name + | otherwise -> mhError $ NoSuchChannel name (Just cId, Nothing) -- We matched a channel and there was an explicit sigil, so we -- don't care about the username match. @@ -1125,9 +1151,7 @@ let myName = if displayNick && not (T.null $ userNickname me) then userNickname me else me^.userUsernameL - if name == myName - then mhError "Cannot create a DM channel with yourself" - else do + when (name /= myName) $ do let uName = if displayNick then maybe name (view uiName) @@ -1147,7 +1171,7 @@ member <- MM.mmGetChannelMember (getId nc) UserMe session return $ handleNewChannel True cwd member else - mhError ("No channel or user named " <> name) + mhError $ NoSuchUser name createOrdinaryChannel :: Text -> MH () createOrdinaryChannel name = do @@ -1258,9 +1282,19 @@ refreshChannelZipper -- Finally, set our focus to the newly created channel - -- if the caller requested a change of channel. - when switch $ setFocus (getId nc) + -- if the caller requested a change of channel. Also + -- consider the last join request state field in case + -- this is an asynchronous channel addition triggered by + -- a /join. + lastReq <- use csLastJoinRequest + wasLast <- case lastReq of + Just cId | cId == getId nc -> do + csLastJoinRequest .= Nothing + return True + _ -> return False + when (switch || wasLast) $ setFocus (getId nc) + editMessage :: Post -> MH () editMessage new = do myId <- gets myUserId @@ -1289,6 +1323,34 @@ cId <- use csCurrentChannelId when (postChannelId new == cId) updateViewed +maybePostUsername :: ChatState -> Post -> T.Text +maybePostUsername st p = + fromMaybe T.empty $ do + uId <- postUserId p + usernameForUserId uId st + +runNotifyCommand :: Post -> Bool -> MH () +runNotifyCommand post mentioned = do + outputChan <- use (csResources.crSubprocessLog) + st <- use id + notifyCommand <- use (csResources.crConfiguration.to configActivityNotifyCommand) + case notifyCommand of + Nothing -> return () + Just cmd -> + doAsyncWith Preempt $ do + let messageString = T.unpack $ postMessage post + notified = if mentioned then "1" else "2" + sender = T.unpack $ maybePostUsername st post + runLoggedCommand False outputChan (T.unpack cmd) + [notified, sender, messageString] Nothing Nothing + return $ return () + +maybeNotify :: PostToAdd -> MH () +maybeNotify (OldPost _) = do + return () +maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned + + maybeRingBell :: MH () maybeRingBell = do doBell <- use (csResources.crConfiguration.to configActivityBell) @@ -1302,28 +1364,33 @@ -- viewed). This is a monoid so that it can be folded over when there -- are multiple inbound posts to be processed. data PostProcessMessageAdd = NoAction - | NotifyUser + | NotifyUser [PostToAdd] | UpdateServerViewed - | NotifyUserAndServer + | NotifyUserAndServer [PostToAdd] andProcessWith :: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd -andProcessWith NotifyUserAndServer _ = NotifyUserAndServer -andProcessWith _ NotifyUserAndServer = NotifyUserAndServer -andProcessWith NotifyUser UpdateServerViewed = NotifyUserAndServer -andProcessWith UpdateServerViewed NotifyUser = NotifyUserAndServer -andProcessWith x NoAction = x -andProcessWith _ x = x +andProcessWith NoAction x = x +andProcessWith x NoAction = x +andProcessWith (NotifyUserAndServer p) UpdateServerViewed = NotifyUserAndServer p +andProcessWith (NotifyUserAndServer p1) (NotifyUser p2) = NotifyUserAndServer (p1 <> p2) +andProcessWith (NotifyUserAndServer p1) (NotifyUserAndServer p2) = NotifyUserAndServer (p1 <> p2) +andProcessWith (NotifyUser p1) (NotifyUserAndServer p2) = NotifyUser (p1 <> p2) +andProcessWith (NotifyUser p1) (NotifyUser p2) = NotifyUser (p1 <> p2) +andProcessWith (NotifyUser p) UpdateServerViewed = NotifyUserAndServer p +andProcessWith UpdateServerViewed UpdateServerViewed = UpdateServerViewed +andProcessWith UpdateServerViewed (NotifyUserAndServer p) = NotifyUserAndServer p +andProcessWith UpdateServerViewed (NotifyUser p) = NotifyUserAndServer p -- | postProcessMessageAdd performs the actual actions indicated by -- the corresponding input value. postProcessMessageAdd :: PostProcessMessageAdd -> MH () postProcessMessageAdd ppma = postOp ppma where - postOp NoAction = return () - postOp UpdateServerViewed = updateViewed - postOp NotifyUser = maybeRingBell - postOp NotifyUserAndServer = updateViewed >> maybeRingBell + postOp NoAction = return () + postOp UpdateServerViewed = updateViewed + postOp (NotifyUser p) = maybeRingBell >> mapM_ maybeNotify p + postOp (NotifyUserAndServer p) = updateViewed >> maybeRingBell >> mapM_ maybeNotify p -- | When we add posts to the application state, we either get them -- from the server during scrollback fetches (here called 'OldPost') or @@ -1454,9 +1521,9 @@ originUserAction = if | fromMe -> NoAction | ignoredJoinLeaveMessage -> NoAction - | notifyPref == NotifyOptionAll -> NotifyUser + | notifyPref == NotifyOptionAll -> NotifyUser [newPostData] | notifyPref == NotifyOptionMention - && wasMentioned -> NotifyUser + && wasMentioned -> NotifyUser [newPostData] | otherwise -> NoAction return $ curChannelAction `andProcessWith` originUserAction @@ -1783,7 +1850,7 @@ Just (_, link) -> do opened <- openURL link when (not opened) $ do - mhError "Config option 'urlOpenCommand' missing; cannot open URL." + mhError $ ConfigOptionMissing "urlOpenCommand" setMode Main openURL :: LinkChoice -> MH Bool @@ -1927,7 +1994,7 @@ case openedAll of True -> setMode Main False -> - mhError "Config option 'urlOpenCommand' missing; cannot open URL." + mhError $ ConfigOptionMissing "urlOpenCommand" shouldSkipMessage :: Text -> Bool shouldSkipMessage "" = True @@ -1943,7 +2010,7 @@ case status of Disconnected -> do let m = "Cannot send messages while disconnected." - mhError m + mhError $ GenericError m Connected -> do let chanId = st^.csCurrentChannelId session <- getSession @@ -1955,8 +2022,11 @@ Replying _ p -> do let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p) } void $ MM.mmCreatePost pendingPost session - Editing p -> do - void $ MM.mmUpdatePost (postId p) (postUpdate msg) session + Editing p ty -> do + let body = if ty == CP Emote + then addEmoteFormatting msg + else msg + void $ MM.mmPatchPost (postId p) (postUpdateBody body) session handleNewUserDirect :: User -> MH () handleNewUserDirect newUser = do diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -4,23 +4,23 @@ import Prelude.MH import qualified Control.Concurrent.STM as STM -import Control.Exception (try) +import Control.Exception ( try ) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T -import Lens.Micro.Platform ((%=), (%~), (.~), traversed) -import System.Hclip (setClipboard, ClipboardException(..)) +import Lens.Micro.Platform ( (%=), (%~), (.~), traversed ) +import System.Hclip ( setClipboard, ClipboardException(..) ) import Network.Mattermost.Endpoints -import Network.Mattermost.Types import Network.Mattermost.Lenses -import Network.Mattermost.Exceptions +import Network.Mattermost.Types import Types + -- * Mattermost API -- | Try to run a computation, posting an informative error @@ -33,8 +33,7 @@ tryMM act onSuccess = do result <- liftIO $ try act case result of - Left (MattermostError { mattermostErrorMessage = msg }) -> - return $ mhError msg + Left e -> return $ mhError $ ServerError e Right value -> liftIO $ onSuccess value -- * Background Computation @@ -235,9 +234,8 @@ postErrorMessage' err = addClientMessage =<< newClientMessage Error err -- | Raise a rich error -mhError :: Text -> MH () -mhError err = do - raiseInternalEvent (DisplayError err) +mhError :: MHError -> MH () +mhError err = raiseInternalEvent (DisplayError err) postErrorMessageIO :: Text -> ChatState -> IO ChatState postErrorMessageIO err st = do @@ -283,6 +281,6 @@ MissingCommands cmds -> "Could not set clipboard due to missing one of the " <> "required program(s): " <> (T.pack $ show cmds) - mhError errMsg + mhError $ ClipboardError errMsg Right () -> return () diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -1,13 +1,13 @@ {-# LANGUAGE MultiWayIf #-} -{-#LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module State.Editing where import Prelude () import Prelude.MH -import Brick.Widgets.Edit (Editor, handleEditorEvent, getEditContents, editContentsL) -import Brick.Widgets.Edit (applyEdit) +import Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent + , getEditContents, editContentsL ) import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Arrow import qualified Control.Concurrent.STM as STM @@ -17,23 +17,23 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z -import Data.Time (getCurrentTime) -import Graphics.Vty (Event(..), Key(..), Modifier(..)) -import Lens.Micro.Platform ((%=), (.=), (.~), to) +import Data.Time ( getCurrentTime ) +import Graphics.Vty ( Event(..), Key(..), Modifier(..) ) +import Lens.Micro.Platform ( (%=), (.=), (.~), to ) import qualified System.Environment as Sys import qualified System.Exit as Sys import qualified System.IO as Sys import qualified System.IO.Temp as Sys import qualified System.Process as Sys -import Text.Aspell (AspellResponse(..), mistakeWord, askAspell) +import Text.Aspell ( AspellResponse(..), mistakeWord, askAspell ) +import Network.Mattermost.Types (Post(..)) + import Config -import Types import Events.Keybindings - import State.Common +import Types -import Network.Mattermost.Types (Post(..)) startMultilineEditing :: MH () startMultilineEditing = csEditState.cedMultiline .= True diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -4,21 +4,23 @@ , updateMessageFlag , lastMsg ) - where +where +import Prelude () +import Prelude.MH -import Data.Function (on) +import Data.Function ( on ) import qualified Data.Set as Set import qualified Data.Text as T -import Lens.Micro.Platform ((.=), (%=), (%~), (.~), to, at, - traversed, filtered, ix) +import Lens.Micro.Platform ( (.=), (%=), (%~), (.~), to, at + , traversed, filtered, ix ) + import Network.Mattermost import Network.Mattermost.Types + import State.Common import TimeUtils import Types -import Prelude () -import Prelude.MH -- ---------------------------------------------------------------------- diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -1,16 +1,18 @@ module State.PostListOverlay where +import Prelude () +import Prelude.MH + import qualified Data.Text as T -import Lens.Micro.Platform ((.=)) -import Network.Mattermost.Endpoints -import Network.Mattermost.Types -import Prelude () -import Prelude.MH +import Lens.Micro.Platform ( (.=) ) +import Network.Mattermost.Endpoints +import Network.Mattermost.Types -import State -import State.Common -import Types -import Types.DirectionalSeq (emptyDirSeq) +import State +import State.Common +import Types +import Types.DirectionalSeq (emptyDirSeq) + -- | Create a PostListOverlay with the given content description and -- with a specified list of messages. diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -8,35 +8,36 @@ import Prelude.MH import Brick.BChan -import Brick.Themes (themeToAttrMap, loadCustomizations) +import Brick.Themes ( themeToAttrMap, loadCustomizations ) +import Control.Concurrent.MVar ( newMVar ) import qualified Control.Concurrent.STM as STM -import Control.Concurrent.MVar (newMVar) -import Control.Exception (catch) -import Data.Maybe (fromJust) +import Control.Exception ( catch ) +import Data.Maybe ( fromJust ) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Lens.Micro.Platform ((%~)) -import System.Exit (exitFailure) -import System.FilePath ((), isRelative, dropFileName) -import System.IO (Handle) -import System.IO.Error (catchIOError) +import Lens.Micro.Platform ( (%~) ) +import System.Exit ( exitFailure ) +import System.FilePath ( (), isRelative, dropFileName ) +import System.IO ( Handle ) +import System.IO.Error ( catchIOError ) import Network.Mattermost.Endpoints +import Network.Mattermost.Logging ( mmLoggerDebug ) import Network.Mattermost.Types -import Network.Mattermost.Logging (mmLoggerDebug) import Config import InputHistory -import Login import LastRunState +import Login import State.Messages +import State.Setup.Threads import TeamSelect import Themes -import TimeUtils (lookupLocalTimeZone) -import State.Setup.Threads +import TimeUtils ( lookupLocalTimeZone ) import Types import qualified Zipper as Z + incompleteCredentials :: Config -> ConnectionInfo incompleteCredentials config = ConnectionInfo hStr (configPort config) uStr pStr where @@ -162,7 +163,7 @@ let cr = ChatResources session cd requestChan eventChan slc wac (themeToAttrMap custTheme) userStatusLock - userIdSet config mempty userPrefs + userIdSet config mempty userPrefs mempty initializeState cr myTeam me @@ -210,6 +211,9 @@ -------------------------------------------------------------------- -- Start background worker threads: -- + -- * Syntax definition loader + startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue) + -- * Main async queue worker thread startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue) diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -6,6 +6,7 @@ , startTimezoneMonitorThread , maybeStartSpellChecker , startAsyncWorkerThread + , startSyntaxMapLoaderThread ) where @@ -13,30 +14,32 @@ import Prelude.MH import Brick.BChan -import Control.Concurrent (threadDelay, forkIO, MVar, putMVar, tryTakeMVar) +import Control.Concurrent ( threadDelay, forkIO, MVar, putMVar, tryTakeMVar ) import qualified Control.Concurrent.STM as STM import Control.Concurrent.STM.Delay -import Control.Exception (SomeException, try, finally, fromException) -import Data.List (isInfixOf) +import Control.Exception ( SomeException, try, finally, fromException ) import qualified Data.Foldable as F +import qualified Data.Map as M import qualified Data.Text as T -import Data.Time (getCurrentTime, addUTCTime) -import Lens.Micro.Platform ((.=), (%=), (%~), mapped) -import System.Exit (ExitCode(ExitSuccess)) -import System.IO (hPutStrLn, hFlush) -import System.IO.Temp (openTempFile) -import System.Directory (getTemporaryDirectory) -import Text.Aspell (Aspell, AspellOption(..), startAspell) +import Data.Time ( getCurrentTime, addUTCTime ) +import Lens.Micro.Platform ( (.=), (%=), (%~), mapped ) +import Skylighting.Loader ( loadSyntaxesFromDir ) +import System.Directory ( getTemporaryDirectory ) +import System.Exit ( ExitCode(ExitSuccess) ) +import System.IO ( hPutStrLn, hFlush ) +import System.IO.Temp ( openTempFile ) +import Text.Aspell ( Aspell, AspellOption(..), startAspell ) import Network.Mattermost.Endpoints import Network.Mattermost.Types import Constants import State.Common -import State.Editing (requestSpellCheck) -import TimeUtils (lookupLocalTimeZone) +import State.Editing ( requestSpellCheck ) +import TimeUtils ( lookupLocalTimeZone ) import Types + updateUserStatuses :: STM.TVar (Seq UserId) -> MVar () -> Session -> IO (MH ()) updateUserStatuses usersVar lock session = do lockResult <- tryTakeMVar lock @@ -113,11 +116,7 @@ hFlush logHandle STM.atomically $ STM.writeTChan requestChan $ do - return $ do - let msg = T.pack $ - "An error occurred when running " <> show progName <> - "; see " <> logPath <> " for details." - mhError msg + return $ mhError $ ProgramExecutionFailed (T.pack progName) (T.pack logPath) logMonitor (Just (logPath, logHandle)) @@ -230,6 +229,24 @@ return delayWakeupChan +startSyntaxMapLoaderThread :: Config -> BChan MHEvent -> IO () +startSyntaxMapLoaderThread config eventChan = void $ forkIO $ do + -- Iterate over the configured syntax directories, loading syntax + -- maps. Ensure that entries loaded in earlier directories in the + -- sequence take precedence over entries loaded later. + mMaps <- forM (configSyntaxDirs config) $ \dir -> do + result <- try $ loadSyntaxesFromDir dir + case result of + Left (_::SomeException) -> return Nothing + Right (Left _) -> return Nothing + Right (Right m) -> return $ Just m + + let maps = catMaybes mMaps + finalMap = foldl M.union mempty maps + + writeBChan eventChan $ RespEvent $ do + csResources.crSyntaxMap .= finalMap + ------------------------------------------------------------------- -- Async worker thread @@ -266,16 +283,10 @@ startWork res <- try req case res of - Left e -> - when (not $ shouldIgnore e) $ - case fromException e of - Nothing -> writeBChan eventChan (AsyncErrEvent e) - Just mmErr -> writeBChan eventChan (AsyncMattermostError mmErr) + Left e -> do + let err = case fromException e of + Nothing -> AsyncErrEvent e + Just mmErr -> ServerError mmErr + writeBChan eventChan $ IEvent $ DisplayError err Right upd -> writeBChan eventChan (RespEvent upd) - --- Filter for exceptions that we don't want to report to the user, --- probably because they are not actionable and/or contain no useful --- information. -shouldIgnore :: SomeException -> Bool -shouldIgnore e = "resource vanished" `isInfixOf` show e diff --git a/src/State/UserListOverlay.hs b/src/State/UserListOverlay.hs --- a/src/State/UserListOverlay.hs +++ b/src/State/UserListOverlay.hs @@ -15,25 +15,27 @@ ) where -import qualified Data.Vector as Vec -import qualified Data.Foldable as F -import qualified Data.Text as T -import qualified Data.Sequence as Seq -import qualified Data.HashMap.Strict as HM -import Lens.Micro.Platform ((.=), (%=), (.~), to) -import qualified Network.Mattermost.Endpoints as MM -import Network.Mattermost.Types -import qualified Data.Text.Zipper as Z import Prelude () import Prelude.MH -import qualified Brick.Widgets.List as L import qualified Brick.Widgets.Edit as E +import qualified Brick.Widgets.List as L +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as HM +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Zipper as Z +import qualified Data.Vector as Vec +import Lens.Micro.Platform ( (.=), (%=), (.~), to ) -import Types -import State.Common -import State (changeChannel, addUserToCurrentChannel) +import qualified Network.Mattermost.Endpoints as MM +import Network.Mattermost.Types +import State ( changeChannel, addUserToCurrentChannel ) +import State.Common +import Types + + -- | Show the user list overlay for searching/showing members of the -- current channel. enterChannelMembersUserList :: MH () @@ -89,7 +91,6 @@ enterUserListMode :: UserSearchScope -> (UserInfo -> MH Bool) -> MH () enterUserListMode scope enterHandler = do csUserListOverlay.userListSearchScope .= scope - csUserListOverlay.userListSelected .= Nothing csUserListOverlay.userListSearchInput.E.editContentsL %= Z.clearZipper csUserListOverlay.userListEnterHandler .= enterHandler csUserListOverlay.userListSearching .= False @@ -135,7 +136,6 @@ exitUserListMode :: MH () exitUserListMode = do csUserListOverlay.userListSearchResults .= listFromUserSearchResults mempty - csUserListOverlay.userListSelected .= Nothing csUserListOverlay.userListEnterHandler .= (const $ return False) setMode Main diff --git a/src/TeamSelect.hs b/src/TeamSelect.hs --- a/src/TeamSelect.hs +++ b/src/TeamSelect.hs @@ -1,21 +1,23 @@ module TeamSelect ( interactiveTeamSelection - ) where + ) +where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH -import Brick -import Brick.Widgets.List -import Brick.Widgets.Center -import Brick.Widgets.Border +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.List import qualified Data.Vector as V -import Graphics.Vty -import System.Exit (exitSuccess) +import Graphics.Vty +import System.Exit ( exitSuccess ) -import Network.Mattermost.Types +import Network.Mattermost.Types -import Markdown +import Markdown + type State = List () Team diff --git a/src/Themes.hs b/src/Themes.hs --- a/src/Themes.hs +++ b/src/Themes.hs @@ -47,23 +47,26 @@ -- * Username formatting , colorUsername - ) where + ) +where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH +import Brick +import Brick.Themes +import Brick.Widgets.List +import Brick.Widgets.Skylighting ( attrNameForTokenType + , attrMappingsForStyle + , highlightedCodeBlockAttr + ) +import Data.Hashable ( hash ) import qualified Data.Map as M -import Data.Hashable (hash) -import Graphics.Vty -import Brick -import Brick.Themes -import Brick.Widgets.List -import Brick.Widgets.Skylighting ( attrNameForTokenType, attrMappingsForStyle - , highlightedCodeBlockAttr - ) import qualified Data.Text as T -import qualified Skylighting as Sky -import Skylighting (TokenType(..)) +import Graphics.Vty +import qualified Skylighting.Styles as Sky +import Skylighting.Types ( TokenType(..) ) + helpAttr :: AttrName helpAttr = "help" diff --git a/src/TimeUtils.hs b/src/TimeUtils.hs --- a/src/TimeUtils.hs +++ b/src/TimeUtils.hs @@ -6,19 +6,21 @@ , localTimeText , originTime ) - where +where +import Prelude () +import Prelude.MH + import qualified Data.Text as T -import Data.Time.Clock (UTCTime(..)) -import Data.Time.Format (formatTime, defaultTimeLocale) -import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..)) -import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile) +import Data.Time.Clock ( UTCTime(..) ) +import Data.Time.Format ( formatTime, defaultTimeLocale ) +import Data.Time.LocalTime ( LocalTime(..), TimeOfDay(..) ) +import Data.Time.LocalTime.TimeZone.Olson ( getTimeZoneSeriesFromOlsonFile ) import Data.Time.LocalTime.TimeZone.Series ( localTimeToUTC' , utcToLocalTime') -import Network.Mattermost.Types (ServerTime(..)) -import Prelude () -import Prelude.MH +import Network.Mattermost.Types ( ServerTime(..) ) + -- | Get the timezone series that should be used for converting UTC diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} module Types ( ConnectionStatus(..) , HelpTopic(..) @@ -15,6 +16,7 @@ , ChannelSelectMatch(..) , MatchValue(..) , StartupStateInfo(..) + , MHError(..) , ConnectionInfo(..) , ciHostname , ciPort @@ -37,7 +39,6 @@ , refreshChannelZipper , getChannelIdsInOrder - , trimUserSigil , trimChannelSigil , LinkChoice(LinkChoice) @@ -76,6 +77,7 @@ , csChannelSelectState , csEditState , csClientConfig + , csLastJoinRequest , timeZone , whenMode , setMode @@ -102,7 +104,6 @@ , UserSearchScope(..) , UserListOverlayState - , userListSelected , userListSearchResults , userListSearchInput , userListSearchScope @@ -125,6 +126,7 @@ , crFlaggedPosts , crConn , crConfiguration + , crSyntaxMap , getSession , getResourceSession @@ -185,7 +187,6 @@ , displaynameForUserId , raiseInternalEvent - , userSigil , normalChannelSigil , HighlightSet(..) @@ -203,48 +204,49 @@ import Prelude () import Prelude.MH -import Brick (EventM, Next) import qualified Brick +import Brick ( EventM, Next ) +import Brick.AttrMap ( AttrMap ) import Brick.BChan -import Brick.AttrMap (AttrMap) -import Brick.Widgets.Edit (Editor, editor) -import Brick.Widgets.List (List, list) +import Brick.Widgets.Edit ( Editor, editor ) +import Brick.Widgets.List ( List, list ) +import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.STM as STM -import Control.Concurrent.MVar (MVar) -import Control.Exception (SomeException) +import Control.Exception ( SomeException ) import qualified Control.Monad.State as St import qualified Data.Foldable as F -import qualified Data.Sequence as Seq -import qualified Data.Vector as Vec import qualified Data.HashMap.Strict as HM -import Data.List (partition, sortBy) +import Data.List ( partition, sortBy ) +import qualified Data.Sequence as Seq import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) , (%=), (^?), (.~) , _Just, Traversal', preuse, (^..), folded, to, view ) -import Network.Mattermost (ConnectionData) +import Network.Connection ( HostNotResolved, HostCannotConnect ) +import Skylighting.Types ( SyntaxMap ) +import System.Exit ( ExitCode ) +import Text.Aspell ( Aspell ) + +import Network.Mattermost ( ConnectionData ) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses import Network.Mattermost.Types import Network.Mattermost.Types.Config -import Network.Mattermost.WebSocket (WebsocketEvent) -import Network.Connection (HostNotResolved, HostCannotConnect) -import qualified Data.Text as T -import System.Exit (ExitCode) -import Text.Aspell (Aspell) - -import Zipper (Zipper, focusL, updateList) +import Network.Mattermost.WebSocket ( WebsocketEvent ) +import Completion ( Completer ) import InputHistory - import Types.Channels -import Types.DirectionalSeq(emptyDirSeq) +import Types.DirectionalSeq ( emptyDirSeq ) import Types.KeyEvents -import Types.Posts import Types.Messages +import Types.Posts import Types.Users -import Completion (Completer) +import Zipper ( Zipper, focusL, updateList ) + -- * Configuration -- | A user password is either given to us directly, or a command @@ -254,68 +256,113 @@ | PasswordCommand Text deriving (Eq, Read, Show) --- | These are all the values that can be read in our configuration --- file. -data Config = Config - { configUser :: Maybe Text - , configHost :: Maybe Text - , configTeam :: Maybe Text - , configPort :: Int - , configPass :: Maybe PasswordSource - , configTimeFormat :: Maybe Text - , configDateFormat :: Maybe Text - , configTheme :: Maybe Text - , configThemeCustomizationFile :: Maybe Text - , configSmartBacktick :: Bool - , configURLOpenCommand :: Maybe Text - , configURLOpenCommandInteractive :: Bool - , configActivityBell :: Bool - , configShowBackground :: BackgroundInfo - , configShowMessagePreview :: Bool - , configEnableAspell :: Bool - , configAspellDictionary :: Maybe Text - , configUnsafeUseHTTP :: Bool - , configChannelListWidth :: Int - , configShowOlderEdits :: Bool - , configShowTypingIndicator :: Bool - , configAbsPath :: Maybe FilePath - , configUserKeys :: KeyConfig - , configHyperlinkingMode :: Bool - } deriving (Eq, Show) +-- | This is how we represent the user's configuration. Most fields +-- correspond to configuration file settings (see Config.hs) but some +-- are for internal book-keeping purposes only. +data Config = + Config { configUser :: Maybe Text + -- ^ The username to use when connecting. + , configHost :: Maybe Text + -- ^ The hostname to use when connecting. + , configTeam :: Maybe Text + -- ^ The team name to use when connecting. + , configPort :: Int + -- ^ The port to use when connecting. + , configPass :: Maybe PasswordSource + -- ^ The password source to use when connecting. + , configTimeFormat :: Maybe Text + -- ^ The format string for timestamps. + , configDateFormat :: Maybe Text + -- ^ The format string for dates. + , configTheme :: Maybe Text + -- ^ The name of the theme to use. + , configThemeCustomizationFile :: Maybe Text + -- ^ The path to the theme customization file, if any. + , configSmartBacktick :: Bool + -- ^ Whether to enable smart quoting characters. + , configURLOpenCommand :: Maybe Text + -- ^ The command to use to open URLs. + , configURLOpenCommandInteractive :: Bool + -- ^ Whether the URL-opening command is interactive (i.e. + -- whether it should be given control of the terminal). + , configActivityNotifyCommand :: Maybe T.Text + -- ^ The command to run for activity notifications. + , configActivityBell :: Bool + -- ^ Whether to ring the terminal bell on activity. + , configShowBackground :: BackgroundInfo + -- ^ Whether to show async background worker thread info. + , configShowMessagePreview :: Bool + -- ^ Whether to show the message preview area. + , configEnableAspell :: Bool + -- ^ Whether to enable Aspell spell checking. + , configAspellDictionary :: Maybe Text + -- ^ A specific Aspell dictionary name to use. + , configUnsafeUseHTTP :: Bool + -- ^ Whether to permit an insecure HTTP connection. + , configChannelListWidth :: Int + -- ^ The width, in columns, of the channel list sidebar. + , configShowOlderEdits :: Bool + -- ^ Whether to highlight the edit indicator on edits made + -- prior to the beginning of the current session. + , configShowTypingIndicator :: Bool + -- ^ Whether to show the typing indicator for other users, + -- and whether to send typing notifications to other users. + , configAbsPath :: Maybe FilePath + -- ^ A book-keeping field for the absolute path to the + -- configuration. (Not a user setting.) + , configUserKeys :: KeyConfig + -- ^ The user's keybinding configuration. + , configHyperlinkingMode :: Bool + -- ^ Whether to enable terminal hyperlinking mode. + , configSyntaxDirs :: [FilePath] + -- ^ The search path for syntax description XML files. + } deriving (Eq, Show) -data BackgroundInfo = Disabled | Active | ActiveCount deriving (Eq, Show) +-- | The state of the UI diagnostic indicator for the async worker +-- thread. +data BackgroundInfo = + Disabled + -- ^ Disable (do not show) the indicator. + | Active + -- ^ Show the indicator when the thread is working. + | ActiveCount + -- ^ Show the indicator when the thread is working, but include the + -- thread's work queue length. + deriving (Eq, Show) -- * 'MMNames' structures --- | The 'MMNames' record is for listing human-readable --- names and mapping them back to internal IDs. -data MMNames = MMNames - { _cnChans :: [Text] -- ^ All channel names - , _channelNameToChanId :: HashMap Text ChannelId - -- ^ Mapping from channel names to 'ChannelId' values - , _usernameToChanId :: HashMap Text ChannelId - -- ^ Mapping from user names to 'ChannelId' values. Only contains - -- entries for which DM channel IDs are known. - , _cnUsers :: [Text] -- ^ All users - , _cnToUserId :: HashMap Text UserId - -- ^ Mapping from user names to 'UserId' values - } +-- | The 'MMNames' record is for listing human-readable names and +-- mapping them back to internal IDs. +data MMNames = + MMNames { _cnChans :: [Text] -- ^ All channel names + , _channelNameToChanId :: HashMap Text ChannelId + -- ^ Mapping from channel names to 'ChannelId' values + , _usernameToChanId :: HashMap Text ChannelId + -- ^ Mapping from user names to 'ChannelId' values. Only + -- contains entries for which DM channel IDs are known. + , _cnUsers :: [Text] -- ^ All users + , _cnToUserId :: HashMap Text UserId + -- ^ Mapping from user names to 'UserId' values + } +-- | MMNames constructor, seeded with an initial mapping of user ID to +-- user and channel metadata. mkNames :: User -> HashMap UserId User -> Seq Channel -> MMNames -mkNames myUser users chans = MMNames - { _cnChans = sort - [ preferredChannelName c - | c <- toList chans, channelType c /= Direct ] - , _channelNameToChanId = HM.fromList [ (preferredChannelName c, channelId c) | c <- toList chans ] - , _usernameToChanId = HM.fromList $ - [ (userUsername u, c) - | u <- HM.elems users - , c <- lookupChan (getDMChannelName (getId myUser) (getId u)) - ] - , _cnUsers = sort (map userUsername (HM.elems users)) - , _cnToUserId = HM.fromList - [ (userUsername u, getId u) | u <- HM.elems users ] - } +mkNames myUser users chans = + MMNames { _cnChans = sort + [ preferredChannelName c + | c <- toList chans, channelType c /= Direct ] + , _channelNameToChanId = HM.fromList [ (preferredChannelName c, channelId c) | c <- toList chans ] + , _usernameToChanId = HM.fromList $ + [ (userUsername u, c) + | u <- HM.elems users + , c <- lookupChan (getDMChannelName (getId myUser) (getId u)) + ] + , _cnUsers = sort (map userUsername (HM.elems users)) + , _cnToUserId = HM.fromList + [ (userUsername u, getId u) | u <- HM.elems users ] + } where lookupChan n = [ c^.channelIdL | c <- toList chans, c^.channelNameL == n ] @@ -328,38 +375,40 @@ mkChannelZipperList :: MMNames -> [ChannelId] mkChannelZipperList chanNames = - getChannelIdsInOrder chanNames ++ - getDMChannelIdsInOrder chanNames + getChannelIdsInOrder chanNames ++ + getDMChannelIdsInOrder chanNames getChannelIdsInOrder :: MMNames -> [ChannelId] getChannelIdsInOrder n = [ (n ^. channelNameToChanId) HM.! i | i <- n ^. cnChans ] getDMChannelIdsInOrder :: MMNames -> [ChannelId] getDMChannelIdsInOrder n = - [ c | i <- n ^. cnUsers - , c <- maybeToList (HM.lookup i (n ^. usernameToChanId)) - ] + [ c | i <- n ^. cnUsers + , c <- maybeToList (HM.lookup i (n ^. usernameToChanId)) + ] -- * Internal Names and References --- | This 'Name' type is the value used in `brick` to identify the --- currently focused widget or state. -data Name = ChannelMessages ChannelId - | MessageInput - | ChannelList - | HelpViewport - | HelpText - | ScriptHelpText - | ThemeHelpText - | KeybindingHelpText - | ChannelSelectString - | CompletionAlternatives - | JoinChannelList - | UrlList - | MessagePreviewViewport - | UserListSearchInput - | UserListSearchResults - deriving (Eq, Show, Ord) +-- | This 'Name' type is the type used in 'brick' to identify various +-- parts of the interface. +data Name = + ChannelMessages ChannelId + | MessageInput + | ChannelList + | HelpViewport + | HelpText + | ScriptHelpText + | ThemeHelpText + | SyntaxHighlightHelpText + | KeybindingHelpText + | ChannelSelectString + | CompletionAlternatives + | JoinChannelList + | UrlList + | MessagePreviewViewport + | UserListSearchInput + | UserListSearchResults + deriving (Eq, Show, Ord) -- | The sum type of exceptions we expect to encounter on authentication -- failure. We encode them explicitly here so that we can print them in @@ -373,7 +422,9 @@ deriving (Show) -- | Our 'ConnectionInfo' contains exactly as much information as is --- necessary to start a connection with a Mattermost server +-- necessary to start a connection with a Mattermost server. This is +-- built up during interactive authentication and then is used to log +-- in. data ConnectionInfo = ConnectionInfo { _ciHostname :: Text , _ciPort :: Int @@ -383,24 +434,23 @@ makeLenses ''ConnectionInfo --- | We want to continue referring to posts by their IDs, but we don't want to --- have to synthesize new valid IDs for messages from the client --- itself (like error messages or informative client responses). To --- that end, a PostRef can be either a PostId or a newly-generated --- client ID +-- | We want to continue referring to posts by their IDs, but we don't +-- want to have to synthesize new valid IDs for messages from the client +-- itself (like error messages or informative client responses). To that +-- end, a PostRef can be either a PostId or a newly-generated client ID. data PostRef - = MMId PostId - | CLId Int + = MMId PostId + | CLId Int deriving (Eq, Show) --- | For representing links to things in the 'open links' view -data LinkChoice = LinkChoice - { _linkTime :: ServerTime - , _linkUser :: UserRef - , _linkName :: Text - , _linkURL :: Text - , _linkFileId :: Maybe FileId - } deriving (Eq, Show) +-- | This type represents links to things in the 'open links' view. +data LinkChoice = + LinkChoice { _linkTime :: ServerTime + , _linkUser :: UserRef + , _linkName :: Text + , _linkURL :: Text + , _linkFileId :: Maybe FileId + } deriving (Eq, Show) makeLenses ''LinkChoice @@ -408,16 +458,22 @@ normalChannelSigil :: Text normalChannelSigil = "~" -userSigil :: Text -userSigil = "@" - -- ** Channel-matching types +-- | A match in channel selection mode. data ChannelSelectMatch = ChannelSelectMatch { nameBefore :: Text + -- ^ The content of the match before the user's + -- matching input. , nameMatched :: Text + -- ^ The potion of the name that matched the + -- user's input. , nameAfter :: Text + -- ^ The portion of the name that came after the + -- user's matching input. , matchFull :: Text + -- ^ The full string for this entry so it doesn't + -- have to be reassembled from the parts above. } deriving (Eq, Show) @@ -444,112 +500,118 @@ , programExitCode :: ExitCode } -data UserPreferences = UserPreferences - { _userPrefShowJoinLeave :: Bool - , _userPrefFlaggedPostList :: Seq FlaggedPost - , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool - } +data UserPreferences = + UserPreferences { _userPrefShowJoinLeave :: Bool + , _userPrefFlaggedPostList :: Seq FlaggedPost + , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool + } defaultUserPreferences :: UserPreferences -defaultUserPreferences = UserPreferences - { _userPrefShowJoinLeave = True - , _userPrefFlaggedPostList = mempty - , _userPrefGroupChannelPrefs = mempty - } +defaultUserPreferences = + UserPreferences { _userPrefShowJoinLeave = True + , _userPrefFlaggedPostList = mempty + , _userPrefGroupChannelPrefs = mempty + } setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences setUserPreferences = flip (F.foldr go) - where go p u - | Just fp <- preferenceToFlaggedPost p = - u { _userPrefFlaggedPostList = - _userPrefFlaggedPostList u Seq.|> fp - } - | Just gp <- preferenceToGroupChannelPreference p = - u { _userPrefGroupChannelPrefs = - HM.insert - (groupChannelId gp) - (groupChannelShow gp) - (_userPrefGroupChannelPrefs u) - } - | preferenceName p == PreferenceName "join_leave" = - u { _userPrefShowJoinLeave = - preferenceValue p /= PreferenceValue "false" } - | otherwise = u + where go p u + | Just fp <- preferenceToFlaggedPost p = + u { _userPrefFlaggedPostList = + _userPrefFlaggedPostList u Seq.|> fp + } + | Just gp <- preferenceToGroupChannelPreference p = + u { _userPrefGroupChannelPrefs = + HM.insert + (groupChannelId gp) + (groupChannelShow gp) + (_userPrefGroupChannelPrefs u) + } + | preferenceName p == PreferenceName "join_leave" = + u { _userPrefShowJoinLeave = + preferenceValue p /= PreferenceValue "false" } + | otherwise = u --- | 'ChatResources' represents configuration and --- connection-related information, as opposed to --- current model or view information. Information --- that goes in the 'ChatResources' value should be --- limited to information that we read or set up --- prior to setting up the bulk of the application state. -data ChatResources = ChatResources - { _crSession :: Session - , _crConn :: ConnectionData - , _crRequestQueue :: RequestChan - , _crEventQueue :: BChan MHEvent - , _crSubprocessLog :: STM.TChan ProgramOutput - , _crWebsocketActionChan :: STM.TChan WebsocketAction - , _crTheme :: AttrMap - , _crUserStatusLock :: MVar () - , _crUserIdSet :: STM.TVar (Seq UserId) - , _crConfiguration :: Config - , _crFlaggedPosts :: Set PostId - , _crUserPreferences :: UserPreferences - } +-- | 'ChatResources' represents configuration and connection-related +-- information, as opposed to current model or view information. +-- Information that goes in the 'ChatResources' value should be limited +-- to information that we read or set up prior to setting up the bulk of +-- the application state. +data ChatResources = + ChatResources { _crSession :: Session + , _crConn :: ConnectionData + , _crRequestQueue :: RequestChan + , _crEventQueue :: BChan MHEvent + , _crSubprocessLog :: STM.TChan ProgramOutput + , _crWebsocketActionChan :: STM.TChan WebsocketAction + , _crTheme :: AttrMap + , _crUserStatusLock :: MVar () + , _crUserIdSet :: STM.TVar (Seq UserId) + , _crConfiguration :: Config + , _crFlaggedPosts :: Set PostId + , _crUserPreferences :: UserPreferences + , _crSyntaxMap :: SyntaxMap + } --- | The 'ChatEditState' value contains the editor widget itself --- as well as history and metadata we need for editing-related --- operations. -data ChatEditState = ChatEditState - { _cedEditor :: Editor Text Name - , _cedEditMode :: EditMode - , _cedMultiline :: Bool - , _cedInputHistory :: InputHistory - , _cedInputHistoryPosition :: HashMap ChannelId (Maybe Int) - , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode) - , _cedCompleter :: Maybe Completer - , _cedYankBuffer :: Text - , _cedSpellChecker :: Maybe (Aspell, IO ()) - , _cedMisspellings :: Set Text - } +-- | The 'ChatEditState' value contains the editor widget itself as well +-- as history and metadata we need for editing-related operations. +data ChatEditState = + ChatEditState { _cedEditor :: Editor Text Name + , _cedEditMode :: EditMode + , _cedMultiline :: Bool + , _cedInputHistory :: InputHistory + , _cedInputHistoryPosition :: HashMap ChannelId (Maybe Int) + , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode) + , _cedCompleter :: Maybe Completer + , _cedYankBuffer :: Text + , _cedSpellChecker :: Maybe (Aspell, IO ()) + , _cedMisspellings :: Set Text + } +-- | The input mode. data EditMode = NewPost - | Editing Post + -- ^ The input is for a new post. + | Editing Post MessageType + -- ^ The input is to be used as a new body for an existing post of + -- the specified type. | Replying Message Post - deriving (Show) + -- ^ The input is to be used as a new post in reply to the specified + -- post. + deriving (Show) --- | We can initialize a new 'ChatEditState' value with just an --- edit history, which we save locally. +-- | We can initialize a new 'ChatEditState' value with just an edit +-- history, which we save locally. emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> ChatEditState -emptyEditState hist sp = ChatEditState - { _cedEditor = editor MessageInput Nothing "" - , _cedMultiline = False - , _cedInputHistory = hist - , _cedInputHistoryPosition = mempty - , _cedLastChannelInput = mempty - , _cedCompleter = Nothing - , _cedEditMode = NewPost - , _cedYankBuffer = "" - , _cedSpellChecker = sp - , _cedMisspellings = mempty - } +emptyEditState hist sp = + ChatEditState { _cedEditor = editor MessageInput Nothing "" + , _cedMultiline = False + , _cedInputHistory = hist + , _cedInputHistoryPosition = mempty + , _cedLastChannelInput = mempty + , _cedCompleter = Nothing + , _cedEditMode = NewPost + , _cedYankBuffer = "" + , _cedSpellChecker = sp + , _cedMisspellings = mempty + } --- | A 'RequestChan' is a queue of operations we have to perform --- in the background to avoid blocking on the main loop +-- | A 'RequestChan' is a queue of operations we have to perform in the +-- background to avoid blocking on the main loop type RequestChan = STM.TChan (IO (MH ())) -- | The 'HelpScreen' type represents the set of possible 'Help' --- dialogues we have to choose from. -data HelpScreen - = MainHelp - | ScriptHelp - | ThemeHelp - | KeybindingHelp +-- dialogues we have to choose from. +data HelpScreen = + MainHelp + | ScriptHelp + | ThemeHelp + | SyntaxHighlightHelp + | KeybindingHelp deriving (Eq) --- | Help topics +-- | Help topics data HelpTopic = HelpTopic { helpTopicName :: Text , helpTopicDescription :: Text @@ -559,11 +621,10 @@ deriving (Eq) -- | Mode type for the current contents of the post list overlay -data PostListContents - = PostListFlagged - | PostListSearch Text Bool -- for the query and search status - -- | PostListPinned ChannelId - deriving (Eq) +data PostListContents = + PostListFlagged + | PostListSearch Text Bool -- for the query and search status + deriving (Eq) -- | The 'Mode' represents the current dominant UI activity data Mode = @@ -585,33 +646,73 @@ data ConnectionStatus = Connected | Disconnected -- | This is the giant bundle of fields that represents the current --- state of our application at any given time. Some of this should --- be broken out further, but hasn't yet been. -data ChatState = ChatState - { _csResources :: ChatResources - , _csFocus :: Zipper ChannelId - , _csNames :: MMNames - , _csMe :: User - , _csMyTeam :: Team - , _csChannels :: ClientChannels - , _csPostMap :: HashMap PostId Message - , _csUsers :: Users - , _timeZone :: TimeZoneSeries - , _csEditState :: ChatEditState - , _csMode :: Mode - , _csShowMessagePreview :: Bool - , _csChannelSelectState :: ChannelSelectState - , _csRecentChannel :: Maybe ChannelId - , _csUrlList :: List Name LinkChoice - , _csConnectionStatus :: ConnectionStatus - , _csWorkerIsBusy :: Maybe (Maybe Int) - , _csJoinChannelList :: Maybe (List Name Channel) - , _csMessageSelect :: MessageSelectState - , _csPostListOverlay :: PostListOverlayState - , _csUserListOverlay :: UserListOverlayState - , _csClientConfig :: Maybe ClientConfig - } +-- state of our application at any given time. Some of this should be +-- broken out further, but hasn't yet been. +data ChatState = + ChatState { _csResources :: ChatResources + -- ^ Global application-wide resources that don't change + -- much. + , _csFocus :: Zipper ChannelId + -- ^ The channel sidebar zipper that tracks which channel + -- is selected. + , _csNames :: MMNames + -- ^ Mappings between names and user/channel IDs. + , _csMe :: User + -- ^ The authenticated user. + , _csMyTeam :: Team + -- ^ The active team of the authenticated user. + , _csChannels :: ClientChannels + -- ^ The channels that we are showing, including their + -- message lists. + , _csPostMap :: HashMap PostId Message + -- ^ The map of post IDs to messages. This allows us to + -- access messages by ID without having to linearly scan + -- channel message lists. + , _csUsers :: Users + -- ^ All of the users we know about. + , _timeZone :: TimeZoneSeries + -- ^ The client time zone. + , _csEditState :: ChatEditState + -- ^ The state of the input box used for composing and + -- editing messages and commands. + , _csMode :: Mode + -- ^ The current application mode. This is used to + -- dispatch to different rendering and event handling + -- routines. + , _csShowMessagePreview :: Bool + -- ^ Whether to show the message preview area. + , _csChannelSelectState :: ChannelSelectState + -- ^ The state of the user's input and selection for + -- channel selection mode. + , _csRecentChannel :: Maybe ChannelId + -- ^ The most recently-selected channel, if any. + , _csUrlList :: List Name LinkChoice + -- ^ The URL list used to show URLs drawn from messages in + -- a channel. + , _csConnectionStatus :: ConnectionStatus + -- ^ Our view of the connection status. + , _csWorkerIsBusy :: Maybe (Maybe Int) + -- ^ Whether the async worker thread is busy, and its + -- queue length if so. + , _csJoinChannelList :: Maybe (List Name Channel) + -- ^ The list of channels presented in the channel join + -- window. + , _csMessageSelect :: MessageSelectState + -- ^ The state of message selection mode. + , _csPostListOverlay :: PostListOverlayState + -- ^ The state of the post list overlay. + , _csUserListOverlay :: UserListOverlayState + -- ^ The state of the user list overlay. + , _csClientConfig :: Maybe ClientConfig + -- ^ The Mattermost client configuration, as we understand it. + , _csLastJoinRequest :: Maybe ChannelId + -- ^ The most recently-joined channel ID that we look for + -- in an asynchronous join notification, so that we can + -- switch to it in the sidebar. + } +-- | Startup state information that is constructed prior to building a +-- ChatState. data StartupStateInfo = StartupStateInfo { startupStateResources :: ChatResources , startupStateChannelZipper :: Zipper ChannelId @@ -624,41 +725,41 @@ } newState :: StartupStateInfo -> ChatState -newState (StartupStateInfo rs i u m tz hist sp ns) = ChatState - { _csResources = rs - , _csFocus = i - , _csMe = u - , _csMyTeam = m - , _csNames = ns - , _csChannels = noChannels - , _csPostMap = HM.empty - , _csUsers = noUsers - , _timeZone = tz - , _csEditState = emptyEditState hist sp - , _csMode = Main - , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration rs - , _csChannelSelectState = emptyChannelSelectState - , _csRecentChannel = Nothing - , _csUrlList = list UrlList mempty 2 - , _csConnectionStatus = Connected - , _csWorkerIsBusy = Nothing - , _csJoinChannelList = Nothing - , _csMessageSelect = MessageSelectState Nothing - , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing - , _csUserListOverlay = nullUserListOverlayState - , _csClientConfig = Nothing - } +newState (StartupStateInfo {..}) = + ChatState { _csResources = startupStateResources + , _csFocus = startupStateChannelZipper + , _csMe = startupStateConnectedUser + , _csMyTeam = startupStateTeam + , _csNames = startupStateNames + , _csChannels = noChannels + , _csPostMap = HM.empty + , _csUsers = noUsers + , _timeZone = startupStateTimeZone + , _csEditState = emptyEditState startupStateInitialHistory startupStateSpellChecker + , _csMode = Main + , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration startupStateResources + , _csChannelSelectState = emptyChannelSelectState + , _csRecentChannel = Nothing + , _csUrlList = list UrlList mempty 2 + , _csConnectionStatus = Connected + , _csWorkerIsBusy = Nothing + , _csJoinChannelList = Nothing + , _csMessageSelect = MessageSelectState Nothing + , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing + , _csUserListOverlay = nullUserListOverlayState + , _csClientConfig = Nothing + , _csLastJoinRequest = Nothing + } nullUserListOverlayState :: UserListOverlayState nullUserListOverlayState = - UserListOverlayState { _userListSearchResults = listFromUserSearchResults mempty - , _userListSelected = Nothing - , _userListSearchInput = editor UserListSearchInput (Just 1) "" - , _userListSearchScope = AllUsers - , _userListSearching = False + UserListOverlayState { _userListSearchResults = listFromUserSearchResults mempty + , _userListSearchInput = editor UserListSearchInput (Just 1) "" + , _userListSearchScope = AllUsers + , _userListSearching = False , _userListRequestingMore = False - , _userListHasAllResults = False - , _userListEnterHandler = const $ return False + , _userListHasAllResults = False + , _userListEnterHandler = const $ return False } listFromUserSearchResults :: Vec.Vector UserInfo -> List Name UserInfo @@ -667,11 +768,15 @@ -- in Draw.UserListOverlay. list UserListSearchResults rs 1 +-- | A match in channel selection mode. Constructors distinguish +-- between channel and user matches to ensure that a match of each type +-- is distinct. data MatchValue = UserMatch Text | ChannelMatch Text deriving (Eq, Show) +-- | The state of channel selection mode. data ChannelSelectState = ChannelSelectState { _channelSelectInput :: Text , _channelMatches :: [ChannelSelectMatch] @@ -687,25 +792,29 @@ , _selectedMatch = Nothing } +-- | The state of message selection mode. data MessageSelectState = - MessageSelectState { selectMessagePostId :: Maybe PostId } + MessageSelectState { selectMessagePostId :: Maybe PostId + } -data PostListOverlayState = PostListOverlayState - { _postListPosts :: Messages - , _postListSelected :: Maybe PostId - } +-- | The state of the post list overlay. +data PostListOverlayState = + PostListOverlayState { _postListPosts :: Messages + , _postListSelected :: Maybe PostId + } -data UserListOverlayState = UserListOverlayState - { _userListSearchResults :: List Name UserInfo - , _userListSelected :: Maybe PostId - , _userListSearchInput :: Editor Text Name - , _userListSearchScope :: UserSearchScope - , _userListSearching :: Bool - , _userListRequestingMore :: Bool - , _userListHasAllResults :: Bool - , _userListEnterHandler :: UserInfo -> MH Bool - } +-- | The state of the user list overlay. +data UserListOverlayState = + UserListOverlayState { _userListSearchResults :: List Name UserInfo + , _userListSearchInput :: Editor Text Name + , _userListSearchScope :: UserSearchScope + , _userListSearching :: Bool + , _userListRequestingMore :: Bool + , _userListHasAllResults :: Bool + , _userListEnterHandler :: UserInfo -> MH Bool + } +-- | The scope for searching for users in a user list overlay. data UserSearchScope = ChannelMembers ChannelId | ChannelNonMembers ChannelId @@ -714,9 +823,7 @@ -- | Actions that can be sent on the websocket to the server. data WebsocketAction = UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box - -- | GetStatuses - -- | GetStatusesByIds [UserId] - deriving (Read, Show, Eq, Ord) + deriving (Read, Show, Eq, Ord) -- * MH Monad @@ -724,11 +831,10 @@ -- manipulate the application state and also request that the -- application quit newtype MH a = - MH { fromMH :: St.StateT (ChatState, ChatState -> EventM Name (Next ChatState)) - (EventM Name) a } + MH { fromMH :: St.StateT (ChatState, ChatState -> EventM Name (Next ChatState)) (EventM Name) a } --- | Run an 'MM' computation, choosing whether to continue or halt --- based on the resulting +-- | Run an 'MM' computation, choosing whether to continue or halt based +-- on the resulting runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState) runMHEvent st (MH mote) = do ((), (st', rs)) <- St.runStateT mote (st, Brick.continue) @@ -740,54 +846,50 @@ mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH () mhHandleEventLensed ln f event = MH $ do - (st, b) <- St.get - n <- St.lift $ f event (st ^. ln) - St.put (st & ln .~ n , b) + (st, b) <- St.get + n <- St.lift $ f event (st ^. ln) + St.put (st & ln .~ n , b) mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH () mhSuspendAndResume mote = MH $ do - (st, _) <- St.get - St.put (st, \ _ -> Brick.suspendAndResume (mote st)) + (st, _) <- St.get + St.put (st, \ _ -> Brick.suspendAndResume (mote st)) -- | This will request that after this computation finishes the -- application should exit requestQuit :: MH () requestQuit = MH $ do - (st, _) <- St.get - St.put (st, Brick.halt) + (st, _) <- St.get + St.put (st, Brick.halt) instance Functor MH where - fmap f (MH x) = MH (fmap f x) + fmap f (MH x) = MH (fmap f x) instance Applicative MH where - pure x = MH (pure x) - MH f <*> MH x = MH (f <*> x) + pure x = MH (pure x) + MH f <*> MH x = MH (f <*> x) instance Monad MH where - return x = MH (return x) - MH x >>= f = MH (x >>= \ x' -> fromMH (f x')) + return x = MH (return x) + MH x >>= f = MH (x >>= \ x' -> fromMH (f x')) -- We want to pretend that the state is only the ChatState, rather -- than the ChatState and the Brick continuation instance St.MonadState ChatState MH where - get = fst `fmap` MH St.get - put st = MH $ do - (_, c) <- St.get - St.put (st, c) + get = fst `fmap` MH St.get + put st = MH $ do + (_, c) <- St.get + St.put (st, c) instance St.MonadIO MH where - liftIO = MH . St.liftIO + liftIO = MH . St.liftIO -- | This represents events that we handle in the main application loop. -data MHEvent - = WSEvent WebsocketEvent +data MHEvent = + WSEvent WebsocketEvent -- ^ For events that arise from the websocket | RespEvent (MH ()) -- ^ For the result values of async IO operations - | AsyncMattermostError MattermostError - -- ^ For Mattermost-specific exceptions - | AsyncErrEvent SomeException - -- ^ For errors that arise in the course of async IO operations | RefreshWebsocketEvent -- ^ Tell our main loop to refresh the websocket connection | WebsocketParseError String @@ -803,11 +905,38 @@ | IEvent InternalEvent -- ^ MH-internal events -data InternalEvent - = DisplayError Text - -- ^ Display a generic error message to the user - deriving (Eq, Show) +-- | Internal application events. +data InternalEvent = + DisplayError MHError + -- ^ Some kind of application error occurred +-- | Application errors. +data MHError = + GenericError T.Text + -- ^ A generic error message constructor + | NoSuchChannel T.Text + -- ^ The specified channel does not exist + | NoSuchUser T.Text + -- ^ The specified user does not exist + | AmbiguousName T.Text + -- ^ The specified name matches both a user and a channel + | ServerError MattermostError + -- ^ A Mattermost server error occurred + | ClipboardError T.Text + -- ^ A problem occurred trying to deal with yanking or the system + -- clipboard + | ConfigOptionMissing T.Text + -- ^ A missing config option is required to perform an operation + | ProgramExecutionFailed T.Text T.Text + -- ^ Args: program name, path to log file. A problem occurred when + -- running the program. + | NoSuchScript T.Text + -- ^ The specified script was not found + | NoSuchHelpTopic T.Text + -- ^ The specified help topic was not found + | AsyncErrEvent SomeException + -- ^ For errors that arise in the course of async IO operations + -- ** Application State Lenses makeLenses ''ChatResources @@ -850,29 +979,29 @@ csCurrentChannel :: Lens' ChatState ClientChannel csCurrentChannel = - lens (\ st -> findChannelById (st^.csCurrentChannelId) (st^.csChannels) ^?! _Just) - (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId) n) + lens (\ st -> findChannelById (st^.csCurrentChannelId) (st^.csChannels) ^?! _Just) + (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId) n) csChannel :: ChannelId -> Traversal' ChatState ClientChannel csChannel cId = - csChannels . channelByIdL cId + csChannels . channelByIdL cId withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH () withChannel cId = withChannelOrDefault cId () withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a withChannelOrDefault cId deflt mote = do - chan <- preuse (csChannel(cId)) - case chan of - Nothing -> return deflt - Just c -> mote c + chan <- preuse (csChannel(cId)) + case chan of + Nothing -> return deflt + Just c -> mote c -- ** 'ChatState' Helper Functions raiseInternalEvent :: InternalEvent -> MH () raiseInternalEvent ev = do - queue <- use (csResources.crEventQueue) - St.liftIO $ writeBChan queue (IEvent ev) + queue <- use (csResources.crEventQueue) + St.liftIO $ writeBChan queue (IEvent ev) isMine :: ChatState -> Message -> Bool isMine st msg = (UserI $ myUserId st) == msg^.mUser @@ -882,9 +1011,9 @@ getParentMessage :: ChatState -> Message -> Maybe Message getParentMessage st msg - | InReplyTo pId <- msg^.mInReplyToMsg - = st^.csPostMap.at(pId) - | otherwise = Nothing + | InReplyTo pId <- msg^.mInReplyToMsg + = st^.csPostMap.at(pId) + | otherwise = Nothing setUserStatus :: UserId -> Text -> MH () setUserStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) @@ -956,11 +1085,6 @@ | normalChannelSigil `T.isPrefixOf` n = T.tail n | otherwise = n -trimUserSigil :: Text -> Text -trimUserSigil n - | userSigil `T.isPrefixOf` n = T.tail n - | otherwise = n - addNewUser :: UserInfo -> MH () addNewUser u = do csUsers %= addUser u @@ -1018,48 +1142,49 @@ csFocus %= newZip clientPostToMessage :: ClientPost -> Message -clientPostToMessage cp = Message - { _mText = cp^.cpText - , _mUser = case cp^.cpUserOverride of - Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]") - _ -> maybe NoUser UserI $ cp^.cpUser - , _mDate = cp^.cpDate - , _mType = CP $ cp^.cpType - , _mPending = cp^.cpPending - , _mDeleted = cp^.cpDeleted - , _mAttachments = cp^.cpAttachments - , _mInReplyToMsg = - case cp^.cpInReplyToPost of - Nothing -> NotAReply - Just pId -> InReplyTo pId - , _mPostId = Just $ cp^.cpPostId - , _mReactions = cp^.cpReactions - , _mOriginalPost = Just $ cp^.cpOriginalPost - , _mFlagged = False - , _mChannelId = Just $ cp^.cpChannelId - } +clientPostToMessage cp = + Message { _mText = cp^.cpText + , _mUser = + case cp^.cpUserOverride of + Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]") + _ -> maybe NoUser UserI $ cp^.cpUser + , _mDate = cp^.cpDate + , _mType = CP $ cp^.cpType + , _mPending = cp^.cpPending + , _mDeleted = cp^.cpDeleted + , _mAttachments = cp^.cpAttachments + , _mInReplyToMsg = + case cp^.cpInReplyToPost of + Nothing -> NotAReply + Just pId -> InReplyTo pId + , _mPostId = Just $ cp^.cpPostId + , _mReactions = cp^.cpReactions + , _mOriginalPost = Just $ cp^.cpOriginalPost + , _mFlagged = False + , _mChannelId = Just $ cp^.cpChannelId + } -- * Slash Commands --- | The 'CmdArgs' type represents the arguments to a slash-command; --- the type parameter represents the argument structure. +-- | The 'CmdArgs' type represents the arguments to a slash-command; the +-- type parameter represents the argument structure. data CmdArgs :: * -> * where - NoArg :: CmdArgs () - LineArg :: Text -> CmdArgs Text - TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest) + NoArg :: CmdArgs () + LineArg :: Text -> CmdArgs Text + TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest) --- | A 'CmdExec' value represents the implementation of a command --- when provided with its arguments +-- | A 'CmdExec' value represents the implementation of a command when +-- provided with its arguments type CmdExec a = a -> MH () -- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec' --- implementation with a name and a description. -data Cmd = forall a. Cmd - { cmdName :: Text - , cmdDescr :: Text - , cmdArgSpec :: CmdArgs a - , cmdAction :: CmdExec a - } +-- implementation with a name and a description. +data Cmd = + forall a. Cmd { cmdName :: Text + , cmdDescr :: Text + , cmdArgSpec :: CmdArgs a + , cmdAction :: CmdExec a + } -- | Helper function to extract the name out of a 'Cmd' value commandName :: Cmd -> Text @@ -1069,15 +1194,15 @@ hasUnread :: ChatState -> ChannelId -> Bool hasUnread st cId = maybe False id $ do - chan <- findChannelById cId (st^.csChannels) - lastViewTime <- chan^.ccInfo.cdViewed - return $ (chan^.ccInfo.cdUpdated > lastViewTime) || - (isJust $ chan^.ccInfo.cdEditedMessageThreshold) + chan <- findChannelById cId (st^.csChannels) + lastViewTime <- chan^.ccInfo.cdViewed + return $ (chan^.ccInfo.cdUpdated > lastViewTime) || + (isJust $ chan^.ccInfo.cdEditedMessageThreshold) userList :: ChatState -> [UserInfo] userList st = filter showUser $ allUsers (st^.csUsers) - where showUser u = not (isSelf u) && (u^.uiInTeam) - isSelf u = (myUserId st) == (u^.uiId) + where showUser u = not (isSelf u) && (u^.uiInTeam) + isSelf u = (myUserId st) == (u^.uiId) allUserIds :: ChatState -> [UserId] allUserIds st = getAllUserIds $ st^.csUsers @@ -1111,15 +1236,15 @@ sortedUserList :: ChatState -> [UserInfo] sortedUserList st = sortBy cmp yes <> sortBy cmp no - where - cmp = compareUserInfo uiName - dmHasUnread u = - case st^.csNames.usernameToChanId.at(u^.uiName) of - Nothing -> False - Just cId - | (st^.csCurrentChannelId) == cId -> False - | otherwise -> hasUnread st cId - (yes, no) = partition dmHasUnread (filter (not . _uiDeleted) $ userList st) + where + cmp = compareUserInfo uiName + dmHasUnread u = + case st^.csNames.usernameToChanId.at(u^.uiName) of + Nothing -> False + Just cId + | (st^.csCurrentChannelId) == cId -> False + | otherwise -> hasUnread st cId + (yes, no) = partition dmHasUnread (filter (not . _uiDeleted) $ userList st) compareUserInfo :: (Ord a) => Lens' UserInfo a -> UserInfo -> UserInfo -> Ordering compareUserInfo field u1 u2 @@ -1135,13 +1260,17 @@ type UserSet = Set Text type ChannelSet = Set Text -data HighlightSet = HighlightSet - { hUserSet :: Set Text - , hChannelSet :: Set Text - } +-- | The set of usernames, channel names, and language names used for +-- highlighting when rendering messages. +data HighlightSet = + HighlightSet { hUserSet :: Set Text + , hChannelSet :: Set Text + , hSyntaxMap :: SyntaxMap + } getHighlightSet :: ChatState -> HighlightSet -getHighlightSet st = HighlightSet - { hUserSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName) - , hChannelSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) - } +getHighlightSet st = + HighlightSet { hUserSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName) + , hChannelSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) + , hSyntaxMap = st^.csResources.crSyntaxMap + } diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -44,11 +44,15 @@ ) where +import Prelude () +import Prelude.MH + import qualified Data.HashMap.Strict as HM -import Lens.Micro.Platform ((%~), (.~), Traversal', Lens', - makeLenses, ix, at, - to, non) -import Network.Mattermost.Lenses hiding (Lens') +import Lens.Micro.Platform ( (%~), (.~), Traversal', Lens' + , makeLenses, ix, at + , to, non ) + +import Network.Mattermost.Lenses hiding ( Lens' ) import Network.Mattermost.Types ( Channel(..), UserId, ChannelId , ChannelMember(..) , Type(..) @@ -60,11 +64,13 @@ , ServerTime , emptyChannelNotifyProps ) -import Types.Messages (Messages, noMessages, addMessage, clientMessageToMessage) -import Types.Posts (ClientMessageType(UnknownGap), newClientMessage, postIsLeave, postIsJoin) -import Types.Users (TypingUsers, noTypingUsers, addTypingUser) -import Prelude () -import Prelude.MH + +import Types.Messages ( Messages, noMessages, addMessage + , clientMessageToMessage ) +import Types.Posts ( ClientMessageType(UnknownGap) + , newClientMessage, postIsLeave, postIsJoin ) +import Types.Users ( TypingUsers, noTypingUsers, addTypingUser ) + -- * Channel representations diff --git a/src/Types/DirectionalSeq.hs b/src/Types/DirectionalSeq.hs --- a/src/Types/DirectionalSeq.hs +++ b/src/Types/DirectionalSeq.hs @@ -11,10 +11,10 @@ module Types.DirectionalSeq where - -import qualified Data.Sequence as Seq import Prelude () import Prelude.MH + +import qualified Data.Sequence as Seq data Chronological diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -22,12 +22,13 @@ ) where +import Prelude () +import Prelude.MH + import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Prelude () -import Prelude.MH -- | This enum represents all the possible key events a user might -- want to use. diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -73,16 +73,21 @@ ) where -import Cheapskate (Blocks) +import Prelude () +import Prelude.MH + +import Cheapskate ( Blocks ) import qualified Data.Map.Strict as Map import Data.Sequence as Seq import Data.Tuple -import Lens.Micro.Platform (makeLenses) -import Network.Mattermost.Types (ChannelId, PostId, Post, ServerTime, UserId) +import Lens.Micro.Platform ( makeLenses ) + +import Network.Mattermost.Types ( ChannelId, PostId, Post + , ServerTime, UserId ) + import Types.DirectionalSeq import Types.Posts -import Prelude () -import Prelude.MH + -- ---------------------------------------------------------------------- -- * Messages diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -44,17 +44,20 @@ ) where -import Cheapskate (Blocks) +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 -import Data.Time.Clock (getCurrentTime) -import Lens.Micro.Platform (makeLenses) -import Network.Mattermost.Types +import Data.Time.Clock ( getCurrentTime ) +import Lens.Micro.Platform ( makeLenses ) + import Network.Mattermost.Lenses -import Prelude () -import Prelude.MH +import Network.Mattermost.Types + -- * Client Messages diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -13,6 +13,8 @@ -- * Creating UserInfo objects , userInfoFromUser -- * Miscellaneous + , userSigil + , trimUserSigil , statusFromText , findUserById , findUserByName @@ -32,14 +34,17 @@ ) where -import Data.Semigroup (Max(..)) -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import Lens.Micro.Platform ((%~), makeLenses, ix) -import Network.Mattermost.Types (Id(Id), UserId(..), User(..), idString) import Prelude () import Prelude.MH +import qualified Data.HashMap.Strict as HM +import Data.Semigroup ( Max(..) ) +import qualified Data.Text as T +import Lens.Micro.Platform ( (%~), makeLenses, ix ) + +import Network.Mattermost.Types ( Id(Id), UserId(..), User(..) + , idString ) + -- * 'UserInfo' Values -- | A 'UserInfo' value represents everything we need to know at @@ -152,21 +157,31 @@ findUserById :: UserId -> Users -> Maybe UserInfo findUserById uId = HM.lookup uId . _ofUsers --- | Get the User information given the user's name. This is an exact --- match on the username field, not necessarly the presented name. +-- | Get the User information given the user's name. This is an exact +-- match on the username field, not necessarly the presented name. It +-- will automatically trim a user sigil from the input. findUserByName :: Users -> Text -> Maybe (UserId, UserInfo) findUserByName allusers name = - case filter ((== name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of + case filter ((== trimUserSigil name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of (usr : []) -> Just usr _ -> Nothing --- | Get the User information given the user's name. This is an exact --- match on the nickname field, not necessarily the presented name. +-- | Get the User information given the user's name. This is an exact +-- match on the nickname field, not necessarily the presented name. It +-- will automatically trim a user sigil from the input. findUserByNickname :: [UserInfo] -> Text -> Maybe UserInfo findUserByNickname uList nick = find (nickCheck nick) uList where - nickCheck n = maybe False (== n) . _uiNickName + nickCheck n = maybe False (== (trimUserSigil n)) . _uiNickName + +userSigil :: Text +userSigil = "@" + +trimUserSigil :: Text -> Text +trimUserSigil n + | userSigil `T.isPrefixOf` n = T.tail n + | otherwise = n -- | Extract a specific user from the collection and perform an -- endomorphism operation on it, then put it back into the collection. diff --git a/src/Zipper.hs b/src/Zipper.hs --- a/src/Zipper.hs +++ b/src/Zipper.hs @@ -14,12 +14,12 @@ ) where -import Prelude () -import Prelude.MH +import Prelude () +import Prelude.MH import qualified Data.Foldable as F +import Lens.Micro.Platform ( Lens, lens, ix, (.~) ) -import Lens.Micro.Platform (Lens, lens, ix, (.~)) data Zipper a = Zipper { zFocus :: Int