matterhorn 40800.0.0 → 40800.0.2
raw patch · 63 files changed
+849/−717 lines, 63 filesdep ~asyncdep ~brickdep ~mattermost-api
Dependency ranges changed: async, brick, mattermost-api, mattermost-api-qc, tasty, tasty-hunit, tasty-quickcheck, vty
Files
- CHANGELOG.md +32/−0
- README.md +7/−0
- matterhorn.cabal +19/−15
- src/App.hs +1/−3
- src/Command.hs +8/−13
- src/Completion.hs +5/−6
- src/Config.hs +5/−9
- src/Connection.hs +3/−6
- src/Constants.hs +2/−1
- src/Draw/ChannelList.hs +50/−43
- src/Draw/DeleteChannelConfirm.hs +1/−3
- src/Draw/JoinChannel.hs +2/−4
- src/Draw/LeaveChannelConfirm.hs +1/−3
- src/Draw/Main.hs +11/−28
- src/Draw/Messages.hs +5/−9
- src/Draw/PostListOverlay.hs +12/−12
- src/Draw/ShowHelp.hs +6/−11
- src/Draw/UserListOverlay.hs +3/−6
- src/Draw/Util.hs +10/−16
- src/Events.hs +16/−15
- src/Events/ChannelScroll.hs +1/−2
- src/Events/ChannelSelect.hs +6/−5
- src/Events/DeleteChannelConfirm.hs +1/−1
- src/Events/JoinChannel.hs +2/−2
- src/Events/Keybindings.hs +6/−6
- src/Events/LeaveChannelConfirm.hs +1/−1
- src/Events/Main.hs +3/−7
- src/Events/MessageSelect.hs +1/−2
- src/Events/PostListOverlay.hs +2/−0
- src/Events/ShowHelp.hs +1/−1
- src/Events/UrlSelect.hs +1/−1
- src/Events/UserListOverlay.hs +2/−1
- src/FilePaths.hs +2/−5
- src/HelpTopics.hs +2/−5
- src/IOUtil.hs +1/−2
- src/InputHistory.hs +3/−4
- src/LastRunState.hs +2/−4
- src/Login.hs +5/−7
- src/Main.hs +1/−2
- src/Markdown.hs +32/−36
- src/Options.hs +1/−1
- src/Prelude/MH.hs +84/−0
- src/Scripts.hs +5/−7
- src/State.hs +146/−101
- src/State/Common.hs +9/−15
- src/State/Editing.hs +9/−12
- src/State/Messages.hs +6/−9
- src/State/PostListOverlay.hs +15/−11
- src/State/Setup.hs +15/−16
- src/State/Setup/Threads.hs +12/−16
- src/State/UserListOverlay.hs +10/−14
- src/TeamSelect.hs +1/−2
- src/Themes.hs +5/−8
- src/TimeUtils.hs +5/−3
- src/Types.hs +154/−118
- src/Types/Channels.hs +10/−9
- src/Types/DirectionalSeq.hs +10/−7
- src/Types/KeyEvents.hs +12/−11
- src/Types/Messages.hs +7/−8
- src/Types/Posts.hs +14/−14
- src/Types/Users.hs +17/−19
- src/Zipper.hs +7/−6
- test/test_messages.hs +21/−13
CHANGELOG.md view
@@ -1,4 +1,36 @@ +40800.0.2+=========++Bug fixes:+ * Matterhorn now properly handles servers with users whose usernames+ match existing channel names.+ * The flagged post list now ignores flagged posts from channels of+ which the current user is no longer a member.+ * Tab-completion now supports nickname completion in the presence of+ user sigils (relevant to #382).+ * The `/search` command now copes better with an empty string as input+ (#359).+ * The `group-msg` command now switches to the relevant channel if it+ already exists (#367).++Other changes:+ * Message edits no longer cause channels to appear to have unread+ activity.+ * The Haskell runtime's idle garbage collector was disabled, reducing+ Matterhorn's idle CPU usage from 2-4% on some systems to zero.++40800.0.1+=========++Bug fixes:+ * User list overlays shown by `/msg`, `/add-user`, and `/members`+ restrict results to the current team only.+ * Message posts, channel view events, and channel metadata update+ events destined for other teams are now properly ignored by+ Matterhorn if the team for those events doesn't match the current+ session's team.+ 40800.0.0 =========
README.md view
@@ -13,6 +13,13 @@ [https://twitter.com/matterhorn_chat](https://twitter.com/matterhorn_chat) +# Chat With the Developers++The Matterhorn developers hang out on the official Mattermost+pre-release server. Stop by to get support and say hello!++[https://pre-release.mattermost.com/core/channels/matterhorn](https://pre-release.mattermost.com/core/channels/matterhorn)+ # Quick Start We provide pre-built binary releases for some platforms. Please see the
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 40800.0.0+version: 40800.0.2 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@@ -8,7 +8,7 @@ license-file: LICENSE author: matterhorn@galois.com maintainer: matterhorn@galois.com-copyright: ©2016-2017 AUTHORS.txt+copyright: ©2016-2018 AUTHORS.txt category: Chat build-type: Simple cabal-version: >= 1.18@@ -74,6 +74,7 @@ LastRunState Scripts TimeUtils+ Prelude.MH Types Types.Channels Types.DirectionalSeq@@ -88,10 +89,11 @@ Options Paths_matterhorn default-extensions: OverloadedStrings,- ScopedTypeVariables- ghc-options: -Wall -threaded+ ScopedTypeVariables,+ NoImplicitPrelude+ ghc-options: -Wall -threaded -with-rtsopts=-I0 build-depends: base >=4.8 && <5- , mattermost-api == 40800.0.0+ , mattermost-api == 40800.0.1 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6@@ -103,9 +105,9 @@ , config-ini >= 0.1.2 && < 0.2 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4- , brick >= 0.34 && < 0.35+ , brick >= 0.36 && < 0.37 , brick-skylighting >= 0.1 && < 0.2- , vty >= 5.19 && < 5.20+ , vty >= 5.20 && < 5.21 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11@@ -129,7 +131,7 @@ , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2 , aeson >= 1.2.3.0 && < 1.3- , async >= 2.0 && < 2.2+ , async >= 2.2 && < 2.3 default-language: Haskell2010 test-suite test_messages@@ -141,6 +143,7 @@ , Types.Messages , Types.Posts , Types.DirectionalSeq+ , Prelude.MH default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables@@ -148,7 +151,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.10- , brick >= 0.34 && < 0.35+ , brick >= 0.36 && < 0.37 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5@@ -159,8 +162,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 40800.0.0- , mattermost-api-qc == 40800.0.0+ , mattermost-api == 40800.0.1+ , mattermost-api-qc == 40800.0.1 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -168,9 +171,9 @@ , stm >= 2.4 && < 2.5 , strict >= 0.3 && < 0.4 , string-conversions >= 0.4 && < 0.5- , tasty >= 0.11 && < 0.12- , tasty-hunit >= 0.9 && < 0.10- , tasty-quickcheck >= 0.8 && < 0.10+ , tasty >= 0.11 && < 1.2+ , tasty-hunit >= 0.9 && < 0.12+ , tasty-quickcheck >= 0.8 && < 0.12 , text >= 1.2 && < 1.3 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 1.9@@ -180,5 +183,6 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector <= 0.12.0.1- , vty >= 5.19 && < 5.20+ , vty >= 5.20 && < 5.21 , xdg-basedir >= 0.2 && < 0.3+ , semigroups >= 0.18 && < 0.19
src/App.hs view
@@ -5,13 +5,11 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick-import Data.Monoid ((<>)) import Control.Monad.Trans.Except (runExceptT) import qualified Graphics.Vty as Vty-import Lens.Micro.Platform import System.IO (IOMode(WriteMode), openFile, hClose) import Text.Aspell (stopAspell)
src/Command.hs view
@@ -3,16 +3,11 @@ module Command where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Control.Applicative ((<|>)) import qualified Control.Exception as Exn-import Control.Monad.IO.Class (liftIO)-import Control.Monad (void) import qualified Data.Char as Char-import Data.Monoid ((<>)) import qualified Data.Text as T-import Lens.Micro.Platform import qualified Network.Mattermost.Endpoints as MM import qualified Network.Mattermost.Types as MM import qualified Network.Mattermost.Exceptions as MM@@ -32,7 +27,7 @@ -- for tokenizing the first bits of command input while leaving the -- subsequent chunks unchanged, preserving newlines and other -- important formatting.-unwordHead :: T.Text -> Maybe (T.Text, T.Text)+unwordHead :: Text -> Maybe (Text, Text) unwordHead t = let t' = T.dropWhile Char.isSpace t (w, rs) = T.break Char.isSpace t'@@ -40,13 +35,13 @@ then Nothing else Just (w, T.dropWhile Char.isSpace rs) -printArgSpec :: CmdArgs a -> T.Text+printArgSpec :: CmdArgs a -> Text printArgSpec NoArg = "" printArgSpec (LineArg ts) = "[" <> ts <> "]" printArgSpec (TokenArg t NoArg) = "[" <> t <> "]" printArgSpec (TokenArg t rs) = "[" <> t <> "] " <> printArgSpec rs -matchArgs :: CmdArgs a -> T.Text -> Either T.Text a+matchArgs :: CmdArgs a -> Text -> Either Text a matchArgs NoArg t = case unwordHead t of Nothing -> return () Just (a, as)@@ -103,7 +98,7 @@ removeUserFromCurrentChannel uname , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ -> toggleMessagePreview- , Cmd "focus" "Focus on a named channel"+ , Cmd "focus" "Focus on a channel or user" (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name , Cmd "focus" "Select from available channels" NoArg $ \ () ->@@ -141,12 +136,12 @@ , Cmd "flags" "Open up a pane of flagged posts" NoArg $ \ () -> enterFlaggedPostListMode - , Cmd "search" "Search for posts with given terms" (LineArg "terms") $+ , Cmd "search" "Search for posts with given terms" (LineArg "terms") $ enterSearchResultPostListMode ] -execMMCommand :: T.Text -> T.Text -> MH ()+execMMCommand :: Text -> Text -> MH () execMMCommand name rest = do cId <- use csCurrentChannelId session <- getSession@@ -187,7 +182,7 @@ Just err -> mhError ("Error running command: " <> err) -dispatchCommand :: T.Text -> MH ()+dispatchCommand :: Text -> MH () dispatchCommand cmd = case unwordHead cmd of Just (x, xs)
src/Completion.hs view
@@ -10,10 +10,9 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Data.Char ( isSpace )-import Data.List ( sort ) import qualified Data.Set as Set import qualified Data.Text as T @@ -26,13 +25,13 @@ -- replace the user's input. The two are decoupled specifically to deal -- with permitting nickname completions to "resolve" to usernames. data Completer =- Completer { completionAlternatives :: Z.Zipper (T.Text, T.Text)+ Completer { completionAlternatives :: Z.Zipper (Text, Text) } -- Nothing: no completions. -- Just Left: a single completion. -- Just Right: more than one completion.-wordComplete :: Set.Set (T.Text, T.Text) -> T.Text -> Maybe (Either T.Text Completer)+wordComplete :: Set (Text, Text) -> Text -> Maybe (Either Text Completer) wordComplete options input = let curWord = currentWord input alts = sort $ Set.toList $ Set.filter ((curWord `T.isPrefixOf`) . fst) options@@ -43,7 +42,7 @@ else Just $ Right $ Completer { completionAlternatives = Z.fromList alts } -currentAlternative :: Completer -> (T.Text, T.Text)+currentAlternative :: Completer -> (Text, Text) currentAlternative = Z.focus . completionAlternatives nextCompletion :: Completer -> Completer@@ -54,7 +53,7 @@ -- | trim whitespace and do any other edits we need -- to focus on the current word-currentWord :: T.Text -> T.Text+currentWord :: Text -> Text currentWord line = T.reverse $ T.takeWhile (not . isSpace)
src/Config.hs view
@@ -9,17 +9,13 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Control.Applicative-import Control.Monad (forM) import Control.Monad.Trans.Except import Data.Ini.Config import qualified Data.Map.Strict as M-import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Monoid ((<>)) import System.Directory (makeAbsolute) import System.Process (readProcess) @@ -80,7 +76,7 @@ Just binding -> return (Just (ev, binding)) return conf { configUserKeys = fromMaybe mempty keys } -backgroundField :: T.Text -> Either String BackgroundInfo+backgroundField :: Text -> Either String BackgroundInfo backgroundField t = case t of "Disabled" -> Right Disabled@@ -89,13 +85,13 @@ _ -> Left ("Invalid value " <> show t <> "; must be one of: Disabled, Active, ActiveCount") -stringField :: T.Text -> Either String T.Text+stringField :: Text -> Either String Text stringField t = case isQuoted t of True -> Right $ parseQuotedString t False -> Right t -parseQuotedString :: T.Text -> T.Text+parseQuotedString :: Text -> Text parseQuotedString t = let body = T.drop 1 $ T.init t unescapeQuotes s | T.null s = s@@ -103,7 +99,7 @@ | otherwise = (T.singleton $ T.head s) <> unescapeQuotes (T.drop 1 s) in unescapeQuotes body -isQuoted :: T.Text -> Bool+isQuoted :: Text -> Bool isQuoted t = let quote = "\"" in (quote `T.isPrefixOf` t) &&
src/Connection.hs view
@@ -1,20 +1,17 @@ module Connection where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick.BChan import Control.Concurrent (forkIO, threadDelay) import qualified Control.Concurrent.STM as STM import Control.Exception (SomeException, catch)-import Control.Monad (void)-import Control.Monad.IO.Class (liftIO) import Data.Int (Int64) import qualified Data.HashMap.Strict as HM-import Data.Semigroup (Max(..), (<>))+import Data.Semigroup (Max(..)) import Data.Time (UTCTime(..), secondsToDiffTime, getCurrentTime, diffUTCTime) import Data.Time.Calendar (Day(..))-import Lens.Micro.Platform import Network.Mattermost.Types (ChannelId) import qualified Network.Mattermost.WebSocket as WS@@ -41,7 +38,7 @@ -- | each successful send. -- | Keeps and propagates a map of channel id to last user_typing notification send time -- | so that the new user_typing actions are throttled to be send only once in two seconds.-processWebsocketActions :: ChatState -> WS.MMWebSocket -> Int64 -> HM.HashMap ChannelId (Max UTCTime) -> IO ()+processWebsocketActions :: ChatState -> WS.MMWebSocket -> Int64 -> HashMap ChannelId (Max UTCTime) -> IO () processWebsocketActions st ws s userTypingLastNotifTimeMap = do action <- STM.atomically $ STM.readTChan (st^.csResources.crWebsocketActionChan) if (shouldSendAction action)
src/Constants.hs view
@@ -4,7 +4,8 @@ ) where -import Data.Time (NominalDiffTime)+import Prelude ()+import Prelude.MH -- | The number of rows to consider a "page" when scrolling pageAmount :: Int
src/Draw/ChannelList.hs view
@@ -23,17 +23,16 @@ import qualified Data.Sequence as Seq import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Text as T import Draw.Util-import Lens.Micro.Platform+import Lens.Micro.Platform (Getting, at, non) import State import Themes import Types-import Types.Users+import Prelude ()+import Prelude.MH -type GroupName = T.Text+type GroupName = Text -- | Specify the different groups of channels to be displayed -- vertically in the ChannelList sidebar. This list provides the@@ -71,12 +70,13 @@ -- facilitate efficient take/drop operations when the optimization -- mentioned above is in effect. channelListGroups :: [ ( GroupName- , Getting ChannelSelectMap ChatState ChannelSelectMap- , ChatState -> Maybe Int -> Seq.Seq ChannelListEntry+ , Getting [ChannelSelectMatch] ChatState [ChannelSelectMatch]+ , ChatState -> Maybe Int -> (ChannelListEntry -> Bool) -> Seq ChannelListEntry+ , Text -> MatchValue ) ] channelListGroups =- [ ("Channels", csChannelSelectState.channelMatches, getOrdinaryChannels)- , ("Users", csChannelSelectState.userMatches, getDmChannels)+ [ ("Channels", csChannelSelectState.channelMatches, getOrdinaryChannels, ChannelMatch)+ , ("Users", csChannelSelectState.userMatches, getDmChannels, UserMatch) ] -- | True if there is an active channel selection operation (i.e. in@@ -93,32 +93,37 @@ Widget Fixed Greedy $ do ctx <- getContext - let maybeViewport =- if hasActiveChannelSelection st- then id -- no viewport scrolling when actively selecting a channel- else viewport ChannelList Vertical- selMatch = st^.csChannelSelectState.selectedMatch- renderedGroups =+ let selMatch = st^.csChannelSelectState.selectedMatch+ renderedGroups gs = if hasActiveChannelSelection st- then renderChannelGroup (renderChannelSelectListEntry selMatch) <$>- selectedGroupEntries- else renderChannelGroup renderChannelListEntry <$> plainGroupEntries- plainGroupEntries (n, _m, f) =- (n, f st (Just $ ctx^.availHeightL))- selectedGroupEntries (n, m, f) =- (n, F.foldr (addSelectedChannel m) mempty $ f st Nothing)- addSelectedChannel m e s =- case HM.lookup (entryLabel e) (st^.m) of+ then let (n, es, mkMatchValue) = selectedGroupEntries gs+ in renderChannelGroup (renderChannelSelectListEntry selMatch mkMatchValue) (n, es)+ else renderChannelGroup renderChannelListEntry $ plainGroupEntries gs+ plainGroupEntries (n, _, f, _) =+ (n, f st (Just $ ctx^.availHeightL) (const True))+ selectedGroupEntries (n, m, f, mkMatchValue) =+ let mapping = HM.fromList $ (\match -> (matchFull match, match)) <$> matches+ matches = st^.m+ in ( n+ , F.foldr (addSelectedChannel mapping) mempty $+ f st (Just $ ctx^.availHeightL) (hasChannelSelectMatch mapping)+ , mkMatchValue+ )+ hasChannelSelectMatch matches e =+ HM.member (entryLabel e) matches+ addSelectedChannel matches e s =+ case HM.lookup (entryLabel e) matches of Just y -> SCLE e y Seq.<| s Nothing -> s - render $ maybeViewport $ vBox $ vBox <$>- F.toList <$> (F.toList $ renderedGroups <$> channelListGroups)+ render $ viewport ChannelList Vertical $+ vBox $ vBox <$>+ toList <$> (toList $ renderedGroups <$> channelListGroups) -- | Renders a specific group, given the name of the group and the -- list of entries in that group (which are expected to be either -- ChannelListEntry or SelectedChannelListEntry elements).-renderChannelGroup :: (a -> Widget Name) -> (GroupName, Seq.Seq a) -> Seq.Seq (Widget Name)+renderChannelGroup :: (a -> Widget Name) -> (GroupName, Seq a) -> Seq (Widget Name) renderChannelGroup eRender (groupName, entries) = let header label = hBorderWithLabel $ withDefAttr channelListHeaderAttr $ txt label@@ -128,8 +133,8 @@ -- attributes. This is the object passed to the rendering function so -- that it can determine how to render each channel. data ChannelListEntry =- ChannelListEntry { entrySigil :: T.Text- , entryLabel :: T.Text+ ChannelListEntry { entrySigil :: Text+ , entryLabel :: Text , entryHasUnread :: Bool , entryMentions :: Int , entryIsRecent :: Bool@@ -170,12 +175,11 @@ -- | Render an individual entry when in Channel Select mode, -- highlighting the matching portion, or completely suppressing the -- entry if it doesn't match.-renderChannelSelectListEntry :: T.Text -> SelectedChannelListEntry -> Widget Name-renderChannelSelectListEntry selMatch (SCLE entry match) =- let ChannelSelectMatch preMatch inMatch postMatch = match- fullName = channelNameFromMatch match- maybeSelect = if fullName == selMatch- then withDefAttr currentChannelNameAttr+renderChannelSelectListEntry :: Maybe MatchValue -> (Text -> MatchValue) -> SelectedChannelListEntry -> Widget Name+renderChannelSelectListEntry selMatch mkMatchValue (SCLE entry match) =+ let ChannelSelectMatch preMatch inMatch postMatch fullName = match+ maybeSelect = if Just (mkMatchValue fullName) == selMatch+ then visible . withDefAttr currentChannelNameAttr else id in maybeSelect $ decorateRecent entry $@@ -195,11 +199,11 @@ -- | Extract the names and information about normal channels to be -- displayed in the ChannelList sidebar.-getOrdinaryChannels :: ChatState -> Maybe Int -> Seq.Seq ChannelListEntry-getOrdinaryChannels st _ =+getOrdinaryChannels :: ChatState -> Maybe Int -> (ChannelListEntry -> Bool) -> Seq ChannelListEntry+getOrdinaryChannels st _ _ = Seq.fromList [ ChannelListEntry sigil n unread mentions recent current Nothing | n <- allChannelNames st- , let Just chan = channelIdByName n st+ , let Just chan = channelIdByChannelName n st unread = hasUnread st chan recent = isRecentChannel st chan current = isCurrentChannel st chan@@ -225,9 +229,10 @@ -- entries, there are enough entries before and after the selected -- channel to get the Brick viewport to position the final result in a -- way that is natural.-getDmChannels :: ChatState -> Maybe Int -> Seq.Seq ChannelListEntry-getDmChannels st height =- let es = Seq.fromList+getDmChannels :: ChatState -> Maybe Int -> (ChannelListEntry -> Bool) -> Seq ChannelListEntry+getDmChannels st height matches =+ let es = Seq.filter matches $+ Seq.fromList [ ChannelListEntry (T.cons sigil " ") uname unread mentions recent current (Just $ u^.uiStatus) | u <- sortedUserList st@@ -240,9 +245,11 @@ then u^.uiNickName.non (u^.uiName) else u^.uiName recent = maybe False (isRecentChannel st) m_chanId- m_chanId = channelIdByName (u^.uiName) st+ m_chanId = channelIdByUsername (u^.uiName) st unread = maybe False (hasUnread st) m_chanId- current = maybe False (isCurrentChannel st) m_chanId+ current = case appMode st of+ ChannelSelect -> Just (UserMatch uname) == st^.csChannelSelectState.selectedMatch+ _ -> maybe False (isCurrentChannel st) m_chanId mentions = fromMaybe 0 $ channelMentionCount <$> m_chanId <*> pure st ] (h, t) = Seq.breakl entryIsCurrent es
src/Draw/DeleteChannelConfirm.hs view
@@ -5,15 +5,13 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import Brick.Widgets.Center import Brick.Widgets.Border-import Lens.Micro.Platform ((^.)) import Types-import Types.Channels ( ccInfo, cdName ) import Themes import Draw.Main
src/Draw/JoinChannel.hs view
@@ -5,15 +5,13 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import Brick.Widgets.List import Brick.Widgets.Center import Brick.Widgets.Border import qualified Data.Text as T-import Data.Monoid ((<>))-import Lens.Micro.Platform ((^.)) import qualified Data.Vector as V import Text.Wrap ( defaultWrapSettings, preserveIndentation ) import Network.Mattermost.Types (Channel)@@ -25,7 +23,7 @@ import Draw.Main drawJoinChannel :: ChatState -> [Widget Name]-drawJoinChannel st = joinChannelBox st : (forceAttr "invalid" <$> drawMain st)+drawJoinChannel st = (joinBorders $ joinChannelBox st) : (forceAttr "invalid" <$> drawMain st) joinChannelBox :: ChatState -> Widget Name joinChannelBox st =
src/Draw/LeaveChannelConfirm.hs view
@@ -5,15 +5,13 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import Brick.Widgets.Center import Brick.Widgets.Border-import Lens.Micro.Platform ((^.)) import Types-import Types.Channels ( ccInfo, cdName ) import Themes import Draw.Main
src/Draw/Main.hs view
@@ -2,7 +2,7 @@ module Draw.Main (drawMain) where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import Brick.Widgets.Border@@ -11,22 +11,17 @@ import Brick.Widgets.Edit (editContentsL, renderEditor, getEditContents) import Brick.Widgets.List (renderList) import Control.Arrow ((>>>))-import Control.Monad (foldM) import Control.Monad.Trans.Reader (withReaderT) import Data.Time.Clock (UTCTime(..)) import Data.Time.Calendar (fromGregorian)-import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import qualified Data.Sequence as Seq import qualified Data.Set as S import qualified Data.Foldable as F import Data.List (intersperse)-import Data.Maybe (catMaybes, isJust)-import Data.Monoid ((<>))-import Data.Text (Text) import qualified Data.Text as T import Data.Text.Zipper (cursorPosition, insertChar, getText, gotoEOL) import Data.Char (isSpace, isPunctuation)-import Lens.Micro.Platform+import Lens.Micro.Platform ((.~), (^?!), to, view, folding) import Network.Mattermost.Types (ChannelId, Type(Direct), ServerTime(..), UserId) @@ -37,25 +32,15 @@ import Draw.Util import Markdown import Completion (Completer(..), currentAlternative)-import qualified Zipper as Z import State import Themes import TimeUtils (justAfter, justBefore) import Types-import Types.Channels ( NewMessageIndicator(..)- , ClientChannel- , ccInfo, ccContents- , cdTypingUsers- , cdName, cdType, cdHeader, cdMessages- , findChannelById)-import Types.Messages-import Types.Posts-import Types.Users import Types.KeyEvents import Events.Keybindings import Events.MessageSelect -previewFromInput :: UserId -> T.Text -> Maybe Message+previewFromInput :: UserId -> Text -> Maybe Message previewFromInput _ s | s == T.singleton cursorSentinel = Nothing previewFromInput uId s = -- If it starts with a slash but not /me, this has no preview@@ -89,15 +74,15 @@ -- | Tokens in spell check highlighting. data Token =- Ignore T.Text+ Ignore Text -- ^ This bit of text is to be ignored for the purposes of -- spell-checking.- | Check T.Text+ | Check Text -- ^ This bit of text should be checked against the spell checker's -- misspelling list. deriving (Show) -drawEditorContents :: ChatState -> HighlightSet -> [T.Text] -> Widget Name+drawEditorContents :: ChatState -> HighlightSet -> [Text] -> Widget Name drawEditorContents st hs = let noHighlight = txt . T.unlines in case st^.csEditState.cedSpellChecker of@@ -160,7 +145,7 @@ -- because 1) the user's input might not be valid markdown and 2) even -- if we did that, we'd still have to do this tokenization operation to -- annotate misspellings and reconstruct the user's raw input.-doHighlightMisspellings :: HighlightSet -> S.Set T.Text -> [T.Text] -> Widget Name+doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name doHighlightMisspellings hSet misspellings contents = -- Traverse the input, gathering non-whitespace into tokens and -- checking if they appear in the misspelling collection@@ -345,7 +330,7 @@ cached (ChannelMessages cId) $ vBox $ (withDefAttr loadMoreAttr $ hCenter $ str "<< Press C-b to load more messages >>") :- (F.toList $ renderSingleMessage st hs editCutoff <$> channelMessages)+ (toList $ renderSingleMessage st hs editCutoff <$> channelMessages) MessageSelect -> renderMessagesWithSelect (st^.csMessageSelect) channelMessages MessageSelectDeleteConfirm ->@@ -443,7 +428,7 @@ else cstr)) drawMain :: ChatState -> [Widget Name]-drawMain st = [mainInterface st]+drawMain st = [joinBorders $ mainInterface st] messageSelectBottomBar :: ChatState -> Widget Name messageSelectBottomBar st =@@ -503,7 +488,7 @@ drawCompletionAlternatives :: Completer -> Widget Name drawCompletionAlternatives c =- let alternatives = intersperse (txt " ") $ mkAlternative <$> Z.toList (completionAlternatives c)+ let alternatives = intersperse (txt " ") $ mkAlternative <$> toList (completionAlternatives c) mkAlternative (displayVal, _) = let format = if displayVal == (fst $ currentAlternative c) then visible . withDefAttr completionAlternativeCurrentAttr@@ -608,9 +593,7 @@ _ -> case st^.csEditState.cedCompleter of Just c -> drawCompletionAlternatives c _ -> maybeSubdue $ hBox- [ hLimit channelListWidth hBorder- , borderElem bsIntersectB- , hBorder+ [ hBorder , showTypingUsers , showBusy ]
src/Draw/Messages.hs view
@@ -2,24 +2,20 @@ import Brick import Brick.Widgets.Border-import Control.Monad (foldM) import Control.Monad.Trans.Reader (withReaderT)-import qualified Data.Foldable as F import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes)-import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Graphics.Vty as Vty-import Lens.Micro.Platform+import Lens.Micro.Platform ((.~), to) import Network.Mattermost.Types (ServerTime(..))+import Prelude ()+import Prelude.MH import Draw.Util import Markdown import Themes import Types-import Types.Posts-import Types.Messages maxMessageHeight :: Int maxMessageHeight = 200@@ -27,7 +23,7 @@ -- | nameForUserRef converts the UserRef into a printable name, based -- on the current known user data.-nameForUserRef :: ChatState -> UserRef -> Maybe T.Text+nameForUserRef :: ChatState -> UserRef -> Maybe Text nameForUserRef st uref = case uref of NoUser -> Nothing UserOverride t -> Just t@@ -63,7 +59,7 @@ then Nothing else Just $ withDefAttr clientMessageAttr $ vBox [ txt (" [attached: `" <> a^.attachmentName <> "`]")- | a <- F.toList (msg^.mAttachments)+ | a <- toList (msg^.mAttachments) ] msgReac = if Map.null (msg^.mReactions) then Nothing
src/Draw/PostListOverlay.hs view
@@ -3,13 +3,11 @@ module Draw.PostListOverlay where import Prelude ()-import Prelude.Compat+import Prelude.MH import Control.Monad.Trans.Reader (withReaderT)-import qualified Data.Foldable as F-import Data.Monoid ((<>)) import qualified Data.Text as T-import Lens.Micro.Platform+import Lens.Micro.Platform ((^?), (%~), to) import Network.Mattermost.Types import Network.Mattermost.Lenses @@ -19,9 +17,6 @@ import Themes import Types-import Types.Channels-import Types.Messages-import Types.Users import Draw.Main import Draw.Messages import Draw.Util@@ -36,7 +31,7 @@ drawPostListOverlay :: PostListContents -> ChatState -> [Widget Name] drawPostListOverlay contents st =- drawPostsBox contents st : (forceAttr "invalid" <$> drawMain st)+ (joinBorders $ drawPostsBox contents st) : (forceAttr "invalid" <$> drawMain st) -- | Draw a PostListOverlay as a floating overlay on top of whatever -- is rendered beneath it@@ -50,17 +45,22 @@ PostListFlagged -> "Flagged posts" PostListSearch terms searching -> "Search results" <> if searching then ": " <> terms- else " (" <> (T.pack . show . length) (st^.csPostListOverlay.postListPosts) <> "): " <> terms+ else " (" <> (T.pack . show . length) messages <> "): " <> terms messages = insertDateMarkers- (st^.csPostListOverlay.postListPosts)+ (filterMessages knownChannel $ st^.csPostListOverlay.postListPosts) (getDateFormat st) (st^.timeZone) + knownChannel msg =+ case msg^.mChannelId of+ Just cId | Nothing <- st^?csChannels.channelByIdL(cId) -> False+ _ -> True+ -- The overall contents, with a sensible default even if there -- are no messages messageListContents- | null (st^.csPostListOverlay.postListPosts) =+ | null messages = padTopBottom 1 $ hCenter $ withDefAttr clientEmphAttr $@@ -96,6 +96,6 @@ renderedMessageList = let (s, (before, after)) = splitMessages (st^.csPostListOverlay.postListSelected) messages in case s of- Nothing -> map renderMessageForOverlay (reverse (F.toList messages))+ Nothing -> map renderMessageForOverlay (reverse (toList messages)) Just curMsg -> [unsafeRenderMessageSelection (curMsg, (after, before)) renderMessageForOverlay]
src/Draw/ShowHelp.hs view
@@ -1,21 +1,16 @@ module Draw.ShowHelp (drawShowHelp) where import Prelude ()-import Prelude.Compat+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 Lens.Micro.Platform-import Data.List (intercalate, sort)-import Data.Maybe (isNothing) import qualified Data.Map as M import qualified Data.Text as T-import Data.Monoid ((<>)) import qualified Graphics.Vty as Vty-import GHC.Exts (sortWith, groupWith) import Network.Mattermost.Version (mmApiVersion) import Themes@@ -311,7 +306,7 @@ in T.concat $ mkEntry <$> names ] -attrNameToConfig :: AttrName -> T.Text+attrNameToConfig :: AttrName -> Text attrNameToConfig = T.pack . intercalate "." . attrNameComponents withMargins :: (Int, Int) -> Widget a -> Widget a@@ -322,7 +317,7 @@ hl = ctx^.availHeightL - (2 * vMargin) render $ hLimit wl $ vLimit hl w -keybindSections :: KeyConfig -> [(T.Text, [Keybinding])]+keybindSections :: KeyConfig -> [(Text, [Keybinding])] keybindSections kc = [ ("This Help Page", helpKeybindings kc) , ("Main Interface", mainKeybindings kc)@@ -350,7 +345,7 @@ kbDescColumnWidth :: Int kbDescColumnWidth = 60 -mkKeybindingHelp :: (T.Text, [Keybinding]) -> Widget Name+mkKeybindingHelp :: (Text, [Keybinding]) -> Widget Name mkKeybindingHelp (sectionName, kbs) = (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt $ "Keybindings: " <> sectionName) <=> (hCenter $ vBox $ mkKeybindHelp <$> (sortWith (ppBinding.eventToBinding.kbEvent) kbs))@@ -361,7 +356,7 @@ (vLimit 1 $ hLimit kbDescColumnWidth $ renderText desc <+> fill ' ') -mkKeybindEventSectionHelp :: (T.Text, [Keybinding]) -> Widget Name+mkKeybindEventSectionHelp :: (Text, [Keybinding]) -> Widget Name mkKeybindEventSectionHelp (sectionName, kbs) = let lst = sortWith (fmap keyEventName . kbBindingInfo . head) $ groupWith kbBindingInfo kbs in if all (all (isNothing . kbBindingInfo)) lst@@ -380,5 +375,5 @@ ] mkKeybindEventHelp _ = [] -padTo :: Int -> T.Text -> T.Text+padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " "
src/Draw/UserListOverlay.hs view
@@ -4,15 +4,13 @@ module Draw.UserListOverlay where import Prelude ()-import Prelude.Compat+import Prelude.MH import Control.Monad.Trans.Reader (withReaderT) import qualified Data.Foldable as F import qualified Data.Text as T-import Data.Maybe (catMaybes)-import Data.Monoid ((<>)) import qualified Graphics.Vty as V-import Lens.Micro.Platform+import Lens.Micro.Platform ((%~)) import Brick import Brick.Widgets.Border@@ -22,7 +20,6 @@ import Themes import Types-import Types.Users import Draw.Main import Draw.Util (userSigilFromInfo) @@ -36,7 +33,7 @@ drawUserListOverlay :: ChatState -> [Widget Name] drawUserListOverlay st =- drawUsersBox (st^.csUserListOverlay) :+ (joinBorders $ drawUsersBox (st^.csUserListOverlay)) : (forceAttr "invalid" <$> drawMain st) -- | Draw a PostListOverlay as a floating overlay on top of whatever
src/Draw/Util.hs view
@@ -1,35 +1,29 @@ module Draw.Util where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import qualified Data.Text as T import qualified Data.Set as Set-import Data.Time.Clock (UTCTime(..))-import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)-import Lens.Micro.Platform+import Lens.Micro.Platform (to) import Network.Mattermost.Types import Types-import Types.Channels-import Types.Messages-import Types.Posts-import Types.Users import TimeUtils import Themes -defaultTimeFormat :: T.Text+defaultTimeFormat :: Text defaultTimeFormat = "%R" -defaultDateFormat :: T.Text+defaultDateFormat :: Text defaultDateFormat = "%Y-%m-%d" -getTimeFormat :: ChatState -> T.Text+getTimeFormat :: ChatState -> Text getTimeFormat st = maybe defaultTimeFormat id (st^.csResources.crConfiguration.to configTimeFormat) -getDateFormat :: ChatState -> T.Text+getDateFormat :: ChatState -> Text getDateFormat st = maybe defaultDateFormat id (st^.csResources.crConfiguration.to configDateFormat) @@ -39,7 +33,7 @@ renderDate :: ChatState -> UTCTime -> Widget Name renderDate st = renderUTCTime (getDateFormat st) (st^.timeZone) -renderUTCTime :: T.Text -> TimeZoneSeries -> UTCTime -> Widget a+renderUTCTime :: Text -> TimeZoneSeries -> UTCTime -> Widget a renderUTCTime fmt tz t = if T.null fmt then emptyWidget@@ -51,7 +45,7 @@ -- markers. Note that the actual time of the server and this client -- are still not synchronized, but no manipulations here actually use -- the client time.-insertDateMarkers :: Messages -> T.Text -> TimeZoneSeries -> Messages+insertDateMarkers :: Messages -> Text -> TimeZoneSeries -> Messages insertDateMarkers ms datefmt tz = foldr (addMessage . dateMsg) ms dateRange where dateRange = foldr checkDateChange Set.empty ms checkDateChange m = let msgDay = startOfDay (Just tz) (withServerTime (m^.mDate))@@ -71,7 +65,7 @@ DoNotDisturb -> '×' Other _ -> '?' -mkChannelName :: ChannelInfo -> T.Text+mkChannelName :: ChannelInfo -> Text mkChannelName c = T.append sigil (c^.cdName) where sigil = case c^.cdType of Private -> T.singleton '?'@@ -80,5 +74,5 @@ Direct -> userSigil _ -> T.singleton '!' -mkDMChannelName :: UserInfo -> T.Text+mkDMChannelName :: UserInfo -> Text mkDMChannelName u = T.cons (userSigilFromInfo u) (u^.uiName)
src/Events.hs view
@@ -2,24 +2,20 @@ module Events where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick-import Control.Monad (forM_, when)-import Control.Monad.IO.Class (liftIO)-import Data.List (intercalate) import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Sequence as Seq import qualified Data.Text as T-import Data.Monoid ((<>))-import GHC.Exts (groupWith) import qualified Graphics.Vty as Vty-import Lens.Micro.Platform+import Lens.Micro.Platform ((.=)) import Network.Mattermost.Types import Network.Mattermost.Lenses import Network.Mattermost.WebSocket+import Network.Mattermost.Exceptions (mattermostErrorMessage) import Connection import State@@ -64,6 +60,8 @@ 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) <>@@ -112,13 +110,15 @@ myTId <- gets myTeamId case weEvent we of WMPosted- | Just p <- wepPost (weData we) -> do- -- If the message is a header change, also update the- -- channel metadata.- let wasMentioned = case wepMentions (weData we) of- Just lst -> myId `Set.member` lst- _ -> False- addNewPostedMessage $ RecentPost p wasMentioned+ | Just p <- wepPost (weData we) ->+ when (wepTeamId (weData we) == Just myTId ||+ wepTeamId (weData we) == Nothing) $ do+ -- If the message is a header change, also update+ -- the channel metadata.+ let wasMentioned = case wepMentions (weData we) of+ Just lst -> myId `Set.member` lst+ _ -> False+ addNewPostedMessage $ RecentPost p wasMentioned | otherwise -> return () WMPostEdited@@ -204,7 +204,8 @@ | otherwise -> return () WMChannelUpdated- | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById cId+ | Just cId <- webChannelId $ weBroadcast we ->+ when (webTeamId (weBroadcast we) == Just myTId) $ refreshChannelById cId | otherwise -> return () WMGroupAdded
src/Events/ChannelScroll.hs view
@@ -1,11 +1,10 @@ module Events.ChannelScroll where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import qualified Graphics.Vty as Vty-import Lens.Micro.Platform import Types import Events.Keybindings
src/Events/ChannelSelect.hs view
@@ -1,12 +1,11 @@ module Events.ChannelSelect where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Control.Monad (when) 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@@ -30,8 +29,10 @@ selMatch <- use (csChannelSelectState.selectedMatch) setMode Main- when (selMatch /= "") $ do- changeChannel selMatch++ let switch (UserMatch m) = changeChannel (userSigil <> m)+ switch (ChannelMatch m) = changeChannel (normalChannelSigil <> m)+ maybe (return ()) switch selMatch , mkKb CancelEvent "Cancel channel selection" $ setMode Main , mkKb NextChannelEvent "Select next match" channelSelectNext
src/Events/DeleteChannelConfirm.hs view
@@ -1,7 +1,7 @@ module Events.DeleteChannelConfirm where import Prelude ()-import Prelude.Compat+import Prelude.MH import qualified Graphics.Vty as Vty
src/Events/JoinChannel.hs view
@@ -1,11 +1,11 @@ module Events.JoinChannel where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick.Widgets.List import qualified Graphics.Vty as Vty-import Lens.Micro.Platform+import Lens.Micro.Platform ((.=)) import Network.Mattermost.Types (getId)
src/Events/Keybindings.hs view
@@ -17,23 +17,23 @@ , parseBinding , keyEventName , keyEventFromName+ ) where -import Data.Monoid ((<>)) import qualified Data.Map.Strict as M-import qualified Data.Text as T import qualified Graphics.Vty as Vty-import Lens.Micro.Platform (use) import Types import Types.KeyEvents+import Prelude ()+import Prelude.MH -- * Keybindings -- | A 'Keybinding' represents a keybinding along with its -- implementation data Keybinding =- KB { kbDescription :: T.Text+ KB { kbDescription :: Text , kbEvent :: Vty.Event , kbAction :: MH () , kbBindingInfo :: Maybe KeyEvent@@ -57,14 +57,14 @@ Just kb -> kbAction kb Nothing -> fallthrough e -mkKb :: KeyEvent -> T.Text -> MH () -> KeyConfig -> [Keybinding]+mkKb :: KeyEvent -> Text -> MH () -> KeyConfig -> [Keybinding] mkKb ev msg action conf = [ KB msg (bindingToEvent key) action (Just ev) | key <- allKeys ] where allKeys | Just (BindingList ks) <- M.lookup ev conf = ks | Just Unbound <- M.lookup ev conf = [] | otherwise = defaultBindings ev -staticKb :: T.Text -> Vty.Event -> MH () -> KeyConfig -> [Keybinding]+staticKb :: Text -> Vty.Event -> MH () -> KeyConfig -> [Keybinding] staticKb msg event action _ = [KB msg event action Nothing] mkKeybindings :: [KeyConfig -> [Keybinding]] -> KeyConfig -> [Keybinding]
src/Events/LeaveChannelConfirm.hs view
@@ -1,7 +1,7 @@ module Events.LeaveChannelConfirm where import Prelude ()-import Prelude.Compat+import Prelude.MH import qualified Graphics.Vty as Vty
src/Events/Main.hs view
@@ -2,22 +2,18 @@ module Events.Main where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick hiding (Direction) import Brick.Widgets.Edit-import Data.Maybe (catMaybes)-import Data.Monoid ((<>)) 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+import Lens.Micro.Platform ((%=), (.=), to, at) import Types-import Types.Channels (ccInfo, cdType, clearNewMessageIndicator, clearEditedThreshold)-import Types.Users (uiDeleted, uiName, uiNickName) import Events.Keybindings import State import State.PostListOverlay (enterFlaggedPostListMode)@@ -197,7 +193,7 @@ Just u | u^.uiDeleted -> Nothing Just u -> let mNick = case u^.uiNickName of- Just nick | displayNick -> [(nick, u^.uiName)]+ Just nick | displayNick -> [(userSigil <> nick, userSigil <> u^.uiName), (nick, u^.uiName)] _ -> [] in Just $ [dupe $ u^.uiName, dupe $ userSigil <> u^.uiName] <> mNick )
src/Events/MessageSelect.hs view
@@ -1,9 +1,8 @@ module Events.MessageSelect where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Graphics.Vty as Vty
src/Events/PostListOverlay.hs view
@@ -1,6 +1,8 @@ module Events.PostListOverlay where import qualified Graphics.Vty as Vty+import Prelude ()+import Prelude.MH import Types import Events.Keybindings
src/Events/ShowHelp.hs view
@@ -1,7 +1,7 @@ module Events.ShowHelp where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import qualified Graphics.Vty as Vty
src/Events/UrlSelect.hs view
@@ -1,7 +1,7 @@ module Events.UrlSelect where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick.Widgets.List import qualified Graphics.Vty as Vty
src/Events/UserListOverlay.hs view
@@ -1,7 +1,8 @@ module Events.UserListOverlay where -import Control.Monad (when) import qualified Graphics.Vty as Vty+import Prelude ()+import Prelude.MH import Brick.Widgets.Edit (handleEditorEvent)
src/FilePaths.hs view
@@ -17,12 +17,9 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Control.Monad (forM, filterM)-import Data.Monoid ((<>))-import Data.Maybe (listToMaybe)-import Data.Text (unpack, Text)+import Data.Text (unpack) import System.Directory ( doesFileExist , doesDirectoryExist , getDirectoryContents
src/HelpTopics.hs view
@@ -9,10 +9,7 @@ where import Prelude ()-import Prelude.Compat--import qualified Data.Text as T-import Data.Maybe (listToMaybe)+import Prelude.MH import Types @@ -41,6 +38,6 @@ HelpTopic "keybindings" "Help on overriding keybindings" KeybindingHelp KeybindingHelpText -lookupHelpTopic :: T.Text -> Maybe HelpTopic+lookupHelpTopic :: Text -> Maybe HelpTopic lookupHelpTopic topic = listToMaybe $ filter ((== topic) . helpTopicName) helpTopics
src/IOUtil.hs view
@@ -3,10 +3,9 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH import Control.Exception-import Control.Monad.IO.Class import Control.Monad.Trans.Except import System.IO.Error (ioeGetErrorString)
src/InputHistory.hs view
@@ -10,16 +10,15 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH import Control.Monad.Trans.Except-import Lens.Micro.Platform+import Lens.Micro.Platform ((.~), (^?), (%~), at, ix, makeLenses) 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 Data.Text ( Text ) import qualified System.Posix.Files as P import qualified System.Posix.Types as P @@ -28,7 +27,7 @@ import Network.Mattermost.Types (ChannelId) data InputHistory =- InputHistory { _historyEntries :: HM.HashMap ChannelId (V.Vector Text)+ InputHistory { _historyEntries :: HashMap ChannelId (V.Vector Text) } deriving (Show)
src/LastRunState.hs view
@@ -11,14 +11,13 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Control.Monad (when) 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+import Lens.Micro.Platform (makeLenses) import System.Directory (createDirectoryIfMissing) import System.FilePath (dropFileName) import qualified System.Posix.Files as P@@ -29,7 +28,6 @@ import Network.Mattermost.Types import Network.Mattermost.Lenses import Types-import Types.Channels -- | Run state of the program. This is saved in a file on program exit and -- | looked up from the file on program startup.
src/Login.hs view
@@ -6,7 +6,7 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import Brick.Forms@@ -14,9 +14,7 @@ import Brick.Widgets.Edit import Brick.Widgets.Center import Brick.Widgets.Border-import Control.Monad.IO.Class (liftIO)-import Data.Monoid ((<>))-import Lens.Micro.Platform+import Lens.Micro.Platform ((.~), Lens', makeLenses) import qualified Data.Text as T import Graphics.Vty import System.Exit (exitSuccess)@@ -38,7 +36,7 @@ makeLenses ''State -validHostname :: [T.Text] -> Maybe T.Text+validHostname :: [Text] -> Maybe Text validHostname ls = let s = T.unpack t t = T.concat ls@@ -76,7 +74,7 @@ , appAttrMap = const colorTheme } -editHostname :: (Show n, Ord n) => Lens' s T.Text -> n -> s -> FormFieldState s e n+editHostname :: (Show n, Ord n) => Lens' s Text -> n -> s -> FormFieldState s e n editHostname stLens n = let ini = id val = validHostname@@ -124,7 +122,7 @@ padTop (Pad 1) $ renderError $ renderText $ "Error: " <> renderAuthError e -renderAuthError :: AuthenticationException -> T.Text+renderAuthError :: AuthenticationException -> Text renderAuthError (ConnectError _) = "Could not connect to server" renderAuthError (ResolveError _) =
src/Main.hs view
@@ -1,9 +1,8 @@ module Main where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Data.Monoid ((<>)) import System.Exit (exitFailure) import Config
src/Markdown.hs view
@@ -17,7 +17,7 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick ( (<+>), Widget, textWidth ) import qualified Brick.Widgets.Border as B@@ -30,12 +30,10 @@ , ListType ) import qualified Cheapskate as C-import Data.Text (Text) import qualified Data.Text as T import qualified Data.Foldable as F-import Data.Monoid (First(..), (<>))-import Data.Sequence ( Seq- , ViewL(..)+import Data.Monoid (First(..))+import Data.Sequence ( ViewL(..) , ViewR(..) , (<|) , (|>)@@ -45,8 +43,6 @@ import qualified Skylighting as Sky import qualified Data.Set as Set import qualified Graphics.Vty as V-import Lens.Micro.Platform ((^.))-import Control.Monad (join) import Network.Mattermost.Lenses (postEditAtL, postCreateAtL) import Network.Mattermost.Types (ServerTime(..))@@ -104,9 +100,9 @@ { mdEditThreshold :: Maybe ServerTime , mdShowOlderEdits :: Bool , mdMessage :: Message- , mdUserName :: Maybe T.Text+ , mdUserName :: Maybe Text , mdParentMessage :: Maybe Message- , mdParentUserName :: Maybe T.Text+ , mdParentUserName :: Maybe Text , mdRenderReplyParent :: Bool , mdHighlightSet :: HighlightSet , mdIndentBlocks :: Bool@@ -223,7 +219,7 @@ -- Render markdown with username highlighting renderMarkdown :: HighlightSet -> Blocks -> Widget a renderMarkdown hSet =- B.vBox . F.toList . fmap (blockToWidget hSet) . addBlankLines+ B.vBox . toList . fmap (blockToWidget hSet) . addBlankLines -- Add blank lines only between adjacent elements of the same type, to -- save space@@ -256,10 +252,10 @@ where C.Doc _ bs = C.markdown C.def txt vBox :: F.Foldable f => f (Widget a) -> Widget a-vBox = B.vBox . F.toList+vBox = B.vBox . toList hBox :: F.Foldable f => f (Widget a) -> Widget a-hBox = B.hBox . F.toList+hBox = B.hBox . toList -- @@ -276,7 +272,7 @@ hBox [header n, B.txt " ", toInlineChunk is hSet] blockToWidget hSet (C.Blockquote is) = addQuoting (vBox $ fmap (blockToWidget hSet) is)-blockToWidget hSet (C.List _ l bs) = toList l bs hSet+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@@ -300,7 +296,7 @@ , B.Widget B.Fixed B.Fixed $ return childResult ] -codeBlockToWidget :: Sky.Syntax -> T.Text -> Widget a+codeBlockToWidget :: Sky.Syntax -> Text -> Widget a codeBlockToWidget syntax tx = let result = Sky.tokenize cfg syntax tx cfg = Sky.TokenizerConfig Sky.defaultSyntaxMap False@@ -311,7 +307,7 @@ in (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=> (padding <+> BS.renderRawSource textWithCursor tokLines) -rawCodeBlockToWidget :: T.Text -> Widget a+rawCodeBlockToWidget :: Text -> Widget a rawCodeBlockToWidget tx = B.withDefAttr codeAttr $ let padding = B.padLeftRight 1 (B.vLimit (length theLines) B.vBorder)@@ -328,8 +324,8 @@ ws = fmap gatherWidgets (split width hSet fs) B.render (vBox (fmap hBox ws)) -toList :: ListType -> [Blocks] -> HighlightSet -> Widget a-toList lt bs hSet = vBox+blocksToList :: ListType -> [Blocks] -> HighlightSet -> Widget a+blocksToList lt bs hSet = vBox [ B.txt i <+> (vBox (fmap (blockToWidget hSet) b)) | b <- bs | i <- is ] where is = case lt of@@ -390,7 +386,7 @@ C.LineBreak :< xs -> Fragment TLineBreak n <| go n xs C.Link label url _ :< xs ->- case F.toList label of+ case toList label of [C.Str s] | s == url -> Fragment (TLink url) (Link url) <| go n xs _ -> go (Link url) label <> go n xs C.RawHtml t :< xs ->@@ -461,7 +457,7 @@ Fragment (TStr s) Channel | otherwise -> Fragment (TStr s) n -removeCursor :: T.Text -> T.Text+removeCursor :: Text -> Text removeCursor = T.filter (/= cursorSentinel) split :: Int -> HighlightSet -> Seq Fragment -> Seq (Seq Fragment)@@ -541,13 +537,13 @@ gatherWidgets _ = S.empty -textWithCursor :: T.Text -> Widget a+textWithCursor :: Text -> Widget a textWithCursor t | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t | otherwise = B.txt t -inlinesToText :: Seq C.Inline -> T.Text-inlinesToText = F.fold . fmap go+inlinesText :: Seq C.Inline -> Text+inlinesText = F.fold . fmap go where go (C.Str t) = t go C.Space = " " go C.SoftBreak = " "@@ -560,23 +556,23 @@ go (C.Entity t) = t go (C.RawHtml t) = t -altInlinesString :: S.Seq C.Inline -> T.Text+altInlinesString :: Seq C.Inline -> Text altInlinesString is | S.null is = ""- | otherwise = ":" <> inlinesToText is+ | otherwise = ":" <> inlinesText is -blockGetURLs :: C.Block -> S.Seq (T.Text, T.Text)-blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> F.toList is-blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> F.toList is-blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> F.toList bs-blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (F.toList <$> bss)+blockGetURLs :: C.Block -> Seq (Text, Text)+blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> toList is+blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> toList is+blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> toList bs+blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (toList <$> bss) blockGetURLs _ = mempty -inlineGetURLs :: C.Inline -> S.Seq (T.Text, T.Text)-inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> F.toList is-inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> F.toList is-inlineGetURLs (C.Link is url "") = (url, inlinesToText is) S.<| (mconcat $ inlineGetURLs <$> F.toList is)-inlineGetURLs (C.Link is _ url) = (url, inlinesToText is) S.<| (mconcat $ inlineGetURLs <$> F.toList is)-inlineGetURLs (C.Image is url _) = S.singleton (url, inlinesToText is)+inlineGetURLs :: C.Inline -> Seq (Text, Text)+inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> toList is+inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> toList is+inlineGetURLs (C.Link is url "") = (url, inlinesText is) S.<| (mconcat $ inlineGetURLs <$> toList is)+inlineGetURLs (C.Link is _ url) = (url, inlinesText is) S.<| (mconcat $ inlineGetURLs <$> toList is)+inlineGetURLs (C.Image is url _) = S.singleton (url, inlinesText is) inlineGetURLs _ = mempty replyArrow :: Widget a@@ -586,7 +582,7 @@ , B.str "▸" ] -findVerbatimChunk :: C.Blocks -> Maybe T.Text+findVerbatimChunk :: C.Blocks -> Maybe Text findVerbatimChunk = getFirst . F.foldMap go where go (C.CodeBlock _ t) = First (Just t) go _ = First Nothing
src/Options.hs view
@@ -3,7 +3,7 @@ module Options where import Prelude ()-import Prelude.Compat+import Prelude.MH import Data.Version (showVersion) import Development.GitRev
+ src/Prelude/MH.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-}++{-| This module is for internal re-exports of commonly-used+ functions. This also lets us avoid churn between versions of GHC by+ putting changed functions behind CPP in a single place.+-}++module Prelude.MH+( module P+#if !MIN_VERSION_base(4,11,0)+, (<>)+#endif+, (<|>)+-- commonly-used functions from Maybe+, Maybe.isJust+, Maybe.isNothing+, Maybe.listToMaybe+, Maybe.maybeToList+, Maybe.fromMaybe+, Maybe.catMaybes++-- a non-partial Read function+, Read.readMaybe++-- commonly-used functions from Monad+, Monad.forM+, Monad.forM_+, Monad.filterM+, Monad.when+, Monad.unless+, Monad.void+, Monad.join+, Monad.forever+, Monad.foldM+, Monad.MonadIO(..)++-- commonly-used functions from List+, Foldable.toList+, List.find+, List.sort+, List.intercalate+, Exts.sortWith+, Exts.groupWith++-- common read-only lens operators+, (Lens.&)+, (Lens.^.)+, Lens.use++-- various type aliases+, Text+, HashMap+, Seq+, Set+, Time.UTCTime+, Time.TimeZoneSeries+, Time.NominalDiffTime+) where+++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>))+#endif+import qualified Prelude.Compat as P+import Prelude.Compat+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 GHC.Exts as Exts+import qualified Text.Read as Read+import qualified Lens.Micro.Platform as Lens++-- 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
src/Scripts.hs view
@@ -4,21 +4,19 @@ ) where -import Control.Monad (when)-import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T-import Data.Monoid ((<>)) import Control.Concurrent (takeMVar, newEmptyMVar) import qualified Control.Concurrent.STM as STM import System.Exit (ExitCode(..))-import Lens.Micro.Platform (use)+import Prelude ()+import Prelude.MH import Types import State (sendMessage, runLoggedCommand) import State.Common import FilePaths (Script(..), getAllScripts, locateScriptPath) -findAndRunScript :: T.Text -> T.Text -> MH ()+findAndRunScript :: Text -> Text -> MH () findAndRunScript scriptName input = do fpMb <- liftIO $ locateScriptPath (T.unpack scriptName) outputChan <- use (csResources.crSubprocessLog)@@ -37,7 +35,7 @@ let msg = ("No script named " <> scriptName <> " was found") mhError msg -runScript :: STM.TChan ProgramOutput -> FilePath -> T.Text -> IO (MH ())+runScript :: STM.TChan ProgramOutput -> FilePath -> Text -> IO (MH ()) runScript outputChan fp text = do outputVar <- newEmptyMVar runLoggedCommand True outputChan fp [] (Just $ T.unpack text) (Just outputVar)@@ -72,7 +70,7 @@ ] <> "\n" <> scriptHelpAddendum) mhError errMsg -scriptHelpAddendum :: T.Text+scriptHelpAddendum :: Text scriptHelpAddendum = "For more help with scripts, run the command\n" <> "```\n/help scripts\n```\n"
src/State.hs view
@@ -108,35 +108,30 @@ where import Prelude ()-import Prelude.Compat+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.Applicative import Control.Concurrent.Async (runConcurrently, Concurrently(..), concurrently) import Control.Concurrent (MVar, putMVar, forkIO) import qualified Control.Concurrent.STM as STM import Control.Exception (SomeException, try)-import Control.Monad.IO.Class (liftIO) import Data.Char (isAlphaNum) import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd) import Brick.Widgets.Edit (applyEdit)-import Control.Monad (when, unless, void, forM_, join) import qualified Data.ByteString as BS import Data.Function (on) import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL) import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq-import Data.List (sort, findIndex)-import Data.Maybe (isJust, fromJust, catMaybes, isNothing)-import Data.Monoid ((<>))+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 qualified Data.Vector as V-import qualified Data.Foldable as F import Graphics.Vty (outputIface) import Graphics.Vty.Output.Interface (ringTerminalBell) import Lens.Micro.Platform@@ -156,10 +151,6 @@ import FilePaths import TimeUtils (justBefore, justAfter) import Types-import Types.Channels-import Types.Posts-import Types.Messages-import Types.Users import InputHistory import Themes import Zipper (Zipper)@@ -179,11 +170,15 @@ refreshChannel :: Channel -> ChannelMember -> MH () refreshChannel chan member = do let cId = getId chan+ myTId <- gets myTeamId+ let ourTeam = channelTeamId chan == Nothing ||+ Just myTId == channelTeamId chan - -- If this is a group channel that the user has chosen to hide, ignore+ -- If this is a group channel that the user has chosen to hide or if+ -- the channel is not a channel for the current session's team, ignore -- the refresh request. isHidden <- channelHiddenPreference cId- case isHidden of+ case isHidden || not ourTeam of True -> return () False -> do -- If this channel is unknown, register it first.@@ -201,7 +196,7 @@ member <- MM.mmGetChannelMember cId UserMe session return $ refreshChannel cwd member -createGroupChannel :: T.Text -> MH ()+createGroupChannel :: Text -> MH () createGroupChannel usernameList = do st <- use id me <- gets myUser@@ -226,7 +221,7 @@ let pref = showGroupChannelPref (channelId chan) (me^.userIdL) -- It's possible that the channel already existed, in which -- case we want to request a preference change to show it.- MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session -- (me^.userIdL) $ Seq.fromList [pref]+ MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session cwd <- MM.mmGetChannel (channelId chan) session member <- MM.mmGetChannelMember (channelId chan) UserMe session return $ do@@ -276,7 +271,7 @@ <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session) <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session) - let dataMap = HM.fromList $ F.toList $ (\d -> (channelMemberChannelId d, d)) <$> datas+ let dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap) chansWithData = mkPair <$> chans @@ -429,7 +424,7 @@ let chType = chan^.ccInfo.cdType if chType /= Direct then setMode DeleteChannelConfirm- else mhError "The /delete-channel command cannot be used with direct message channels."+ else mhError "Direct message channels cannot be deleted." deleteCurrentChannel :: MH () deleteCurrentChannel = do@@ -517,12 +512,12 @@ -- * Joining, Leaving, and Inviting -joinChannelByName :: T.Text -> MH ()+joinChannelByName :: Text -> MH () joinChannelByName rawName = do session <- getSession tId <- gets myTeamId doAsyncWith Preempt $ do- result <- try $ MM.mmGetChannelByName tId (trimAnySigil rawName) session+ result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session return $ case result of Left (_::SomeException) -> mhError $ T.pack $ "No such channel: " <> (show rawName) Right chan -> joinChannel $ getId chan@@ -544,7 +539,7 @@ then return chans else loop chans (start+1) chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0- let sortedChans = V.fromList $ F.toList $ Seq.sortBy (compare `on` channelName) chans+ let sortedChans = V.fromList $ toList $ Seq.sortBy (compare `on` channelName) chans return $ do csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2) @@ -568,7 +563,7 @@ tryMM (MM.mmGetChannel cId session) (\cwd -> return $ handleNewChannel False cwd member) -addUserToCurrentChannel :: T.Text -> MH ()+addUserToCurrentChannel :: Text -> MH () addUserToCurrentChannel uname = do -- First: is this a valid username? result <- gets (userByUsername uname)@@ -583,7 +578,7 @@ _ -> do mhError ("No such user: " <> uname) -removeUserFromCurrentChannel :: T.Text -> MH ()+removeUserFromCurrentChannel :: Text -> MH () removeUserFromCurrentChannel uname = do -- First: is this a valid username? result <- gets (userByUsername uname)@@ -633,7 +628,7 @@ , MM.userQueryPerPage = Just 2 , MM.userQueryInChannel = Just cId }- in F.toList <$> MM.mmGetUsers query s)+ in toList <$> MM.mmGetUsers query s) (\_ members -> do -- If the channel is private: -- * leave it if we aren't the last member.@@ -875,7 +870,7 @@ ((" " <>) <$> internalThemeName <$> internalThemes) postInfoMessage themeList -setTheme :: T.Text -> MH ()+setTheme :: Text -> MH () setTheme name = case lookupTheme name of Nothing -> listThemes@@ -962,7 +957,7 @@ -- new block may be discontiguous with the local blocks, in which -- case the new block should be surrounded by UnknownGaps. withChannelOrDefault cId NoAction $ \chan -> do- let pIdList = F.toList (posts^.postsOrderL)+ let pIdList = toList (posts^.postsOrderL) -- the first and list PostId in the batch to be added earliestPId = last pIdList latestPId = head pIdList@@ -1023,10 +1018,10 @@ -- corpus, generating needed fetches of data associated with -- the post, and determining an notification action to be -- taken (if any).- action <- foldr mappend mempty <$>+ action <- foldr andProcessWith NoAction <$> mapM (addMessageToState . OldPost) [ (posts^.postsPostsL) HM.! p- | p <- F.toList (posts^.postsOrderL)+ | p <- toList (posts^.postsOrderL) , not (p `elem` dupPIds) ] @@ -1059,7 +1054,7 @@ let unknownUsers = Set.difference inputUserIds knownUserIds if Set.null unknownUsers then return ()- else handleNewUsers $ Seq.fromList $ F.toList unknownUsers+ else handleNewUsers $ Seq.fromList $ toList unknownUsers addUnknownUsers users @@ -1073,12 +1068,35 @@ -- | This switches to the named channel or creates it if it is a missing -- but valid user channel.-changeChannel :: T.Text -> MH ()+changeChannel :: Text -> MH () 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."+ case result of- Just cId -> setFocus cId- Nothing -> attemptCreateDMChannel name+ (Nothing, Nothing)+ -- We know about the user but there isn't already a DM+ -- channel, so create one.+ | Just _ <- user -> attemptCreateDMChannel name+ -- There were no matches of any kind.+ | otherwise -> mhError $ T.pack $ "No such channel: " <> show name+ (Just cId, Nothing)+ -- We matched a channel and there was an explicit sigil, so we+ -- don't care about the username match.+ | normalChannelSigil `T.isPrefixOf` name -> setFocus cId+ -- We matched both a channel and a user, even though there is+ -- no DM channel.+ | Just _ <- user -> err+ -- We matched a channel only.+ | otherwise -> setFocus cId+ (Nothing, Just cId) ->+ -- We matched a user only and there is already a DM channel.+ setFocus cId+ (Just _, Just _) ->+ -- We matched both a channel and a user.+ err setFocus :: ChannelId -> MH () setFocus cId = setFocusWith (Z.findRight (== cId))@@ -1098,9 +1116,9 @@ updateViewed postChangeChannelCommon -attemptCreateDMChannel :: T.Text -> MH ()+attemptCreateDMChannel :: Text -> MH () attemptCreateDMChannel name = do- mCid <- gets (channelIdByName name)+ mCid <- gets (channelIdByUsername name) me <- gets myUser displayNick <- use (to useNickname) uList <- use (to sortedUserList)@@ -1131,7 +1149,7 @@ else mhError ("No channel or user named " <> name) -createOrdinaryChannel :: T.Text -> MH ()+createOrdinaryChannel :: Text -> MH () createOrdinaryChannel name = do session <- getSession myTId <- gets myTeamId@@ -1172,7 +1190,7 @@ -- Only add the channel to the state if it isn't already known. mChan <- preuse (csChannel(getId nc)) case mChan of- Just _ -> return ()+ Just _ -> when switch $ setFocus (getId nc) Nothing -> do -- Create a new ClientChannel structure cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>@@ -1254,7 +1272,6 @@ when (postUserId new /= Just myId) $ chan %= adjustEditedThreshold new - chan %= adjustUpdated new csPostMap.ix(postId new) .= msg asyncFetchReactionsForPost (postChannelId new) new asyncFetchAttachments new@@ -1289,14 +1306,14 @@ | UpdateServerViewed | NotifyUserAndServer -instance Monoid PostProcessMessageAdd where- mempty = NoAction- mappend NotifyUserAndServer _ = NotifyUserAndServer- mappend _ NotifyUserAndServer = NotifyUserAndServer- mappend NotifyUser UpdateServerViewed = NotifyUserAndServer- mappend UpdateServerViewed NotifyUser = NotifyUserAndServer- mappend x NoAction = x- mappend _ x = x+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 -- | postProcessMessageAdd performs the actual actions indicated by -- the corresponding input value.@@ -1442,7 +1459,7 @@ && wasMentioned -> NotifyUser | otherwise -> NoAction - return $ curChannelAction <> originUserAction+ return $ curChannelAction `andProcessWith` originUserAction doHandleAddedMessage @@ -1490,7 +1507,7 @@ _ -> return () -setChannelTopic :: T.Text -> MH ()+setChannelTopic :: Text -> MH () setChannelTopic msg = do cId <- use csCurrentChannelId let patch = defaultChannelPatch { channelPatchHeader = Just msg }@@ -1577,70 +1594,86 @@ csChannelSelectState.selectedMatch %= \oldMatch -> -- Make the list of all matches, in display order.- let allMatches = concat [ sort $ HM.keys chanMatches- , sort $ HM.keys usernameMatches+ let allMatches = concat [ (ChannelMatch . matchFull) <$> chanMatches+ , (UserMatch . matchFull) <$> usernameMatches ]- in case findIndex (== oldMatch) allMatches of- Nothing -> if null allMatches- then ""- else allMatches !! 0- Just i ->- let newIndex = if tmpIndex < 0- then length allMatches - 1- else if tmpIndex >= length allMatches- then 0- else tmpIndex- tmpIndex = nextIndex i- in allMatches !! newIndex+ defaultMatch = if null allMatches+ then Nothing+ else Just $ allMatches !! 0+ in case oldMatch of+ Nothing -> defaultMatch+ Just oldMatch' -> case findIndex (== oldMatch') allMatches of+ Nothing -> defaultMatch+ Just i ->+ let newIndex = if tmpIndex < 0+ then length allMatches - 1+ else if tmpIndex >= length allMatches+ then 0+ else tmpIndex+ tmpIndex = nextIndex i+ in Just $ allMatches !! newIndex updateChannelSelectMatches :: MH () updateChannelSelectMatches = do -- Given the current channel select string, find all the channel and -- user matches and then update the match lists.- chanNameMatches <- use (csChannelSelectState.channelSelectInput.to channelNameMatch)- chanNames <- gets allChannelNames+ input <- use (csChannelSelectState.channelSelectInput)+ let pat = parseChannelSelectPattern input+ chanNameMatches = case pat of+ Nothing -> const Nothing+ Just p -> if T.null input+ then const Nothing+ else applySelectPattern p+ patTy = case pat of+ Nothing -> Nothing+ Just (CSP ty _) -> Just ty++ chanNames <- gets (sort . allChannelNames) uList <- use (to sortedUserList) displayNick <- use (to useNickname)- let chanMatches = catMaybes (fmap chanNameMatches chanNames)+ let chanMatches = if patTy == Just UsersOnly+ then mempty+ else catMaybes (fmap chanNameMatches chanNames) displayName uInf | displayNick = uInf^.uiNickName.non (uInf^.uiName) | otherwise = uInf^.uiName- usernameMatches = catMaybes (fmap (chanNameMatches . displayName) uList)- mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms]+ usernameMatches = if patTy == Just ChannelsOnly+ then mempty+ else catMaybes (fmap (chanNameMatches . displayName) uList) newInput <- use (csChannelSelectState.channelSelectInput)- csChannelSelectState.channelMatches .= mkMap chanMatches- csChannelSelectState.userMatches .= mkMap usernameMatches+ csChannelSelectState.channelMatches .= chanMatches+ csChannelSelectState.userMatches .= usernameMatches csChannelSelectState.selectedMatch %= \oldMatch -> -- If the user input exactly matches one of the matches, prefer -- that one. Otherwise, if the previously selected match is -- still a possible match, leave it selected. Otherwise revert -- to the first available match.- let newMatch = if newInput `elem` allMatches- then newInput- else if oldMatch `elem` allMatches- then oldMatch- else firstAvailableMatch- unames = channelNameFromMatch <$> usernameMatches- allMatches = concat [ channelNameFromMatch <$> chanMatches- , [ displayName u | u <- uList- , displayName u `elem` unames- ]- ]- firstAvailableMatch = if null allMatches- then ""- else head allMatches+ let unames = matchFull <$> usernameMatches+ cnames = matchFull <$> chanMatches+ firstAvailableMatch =+ if null chanMatches+ then if null unames+ then Nothing+ else Just $ UserMatch $ head unames+ else Just $ ChannelMatch $ head cnames+ newMatch = case oldMatch of+ Just (UserMatch u) ->+ if newInput `elem` unames+ then Just $ UserMatch newInput+ else if u `elem` unames+ then oldMatch+ else firstAvailableMatch+ Just (ChannelMatch c) ->+ if newInput `elem` cnames+ then Just $ ChannelMatch $ newInput+ else if c `elem` cnames+ then oldMatch+ else firstAvailableMatch+ Nothing -> firstAvailableMatch in newMatch -channelNameMatch :: T.Text -> T.Text -> Maybe ChannelSelectMatch-channelNameMatch patStr chanName =- if T.null patStr- then Nothing- else do- pat <- parseChannelSelectPattern patStr- applySelectPattern pat chanName--applySelectPattern :: ChannelSelectPattern -> T.Text -> Maybe ChannelSelectMatch+applySelectPattern :: ChannelSelectPattern -> Text -> Maybe ChannelSelectMatch applySelectPattern (CSP ty pat) chanName = do let applyType Infix | pat `T.isInfixOf` chanName = case T.breakOn pat chanName of@@ -1650,6 +1683,14 @@ let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) + applyType UsersOnly | pat `T.isPrefixOf` chanName = do+ let (b, a) = T.splitAt (T.length pat) chanName+ return ("", b, a)++ applyType ChannelsOnly | pat `T.isPrefixOf` chanName = do+ let (b, a) = T.splitAt (T.length pat) chanName+ return ("", b, a)+ applyType Suffix | pat `T.isSuffixOf` chanName = do let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName return (b, a, "")@@ -1660,10 +1701,14 @@ applyType _ = Nothing (pre, m, post) <- applyType ty- return $ ChannelSelectMatch pre m post+ return $ ChannelSelectMatch pre m post chanName -parseChannelSelectPattern :: T.Text -> Maybe ChannelSelectPattern+parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern parseChannelSelectPattern pat = do+ let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP UsersOnly $ T.tail pat+ | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP ChannelsOnly $ T.tail pat+ | otherwise -> Nothing+ (pat1, pfx) <- case "^" `T.isPrefixOf` pat of True -> return (T.tail pat, Just Prefix) False -> return (pat, Nothing)@@ -1672,7 +1717,7 @@ True -> return (T.init pat1, Just Suffix) False -> return (pat1, Nothing) - case (pfx, sfx) of+ only <|> case (pfx, sfx) of (Nothing, Nothing) -> return $ CSP Infix pat2 (Just Prefix, Nothing) -> return $ CSP Prefix pat2 (Nothing, Just Suffix) -> return $ CSP Suffix pat2@@ -1691,7 +1736,7 @@ findUrls :: ClientChannel -> [LinkChoice] findUrls chan = let msgs = chan^.ccContents.cdMessages- in removeDuplicates $ concat $ F.toList $ F.toList <$> msgURLs <$> msgs+ in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs -- XXX: move this somewhere more sensible! @@ -1713,13 +1758,13 @@ removeDuplicates :: [LinkChoice] -> [LinkChoice] removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser)) -msgURLs :: Message -> Seq.Seq LinkChoice+msgURLs :: Message -> Seq LinkChoice msgURLs msg | NoUser <- msg^.mUser = mempty | otherwise = let uid = msg^.mUser msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$>- (mconcat $ blockGetURLs <$> (F.toList $ msg^.mText))+ (mconcat $ blockGetURLs <$> (toList $ msg^.mText)) attachmentURLs = (\ a -> LinkChoice (msg^.mDate)@@ -1884,11 +1929,11 @@ False -> mhError "Config option 'urlOpenCommand' missing; cannot open URL." -shouldSkipMessage :: T.Text -> Bool+shouldSkipMessage :: Text -> Bool shouldSkipMessage "" = True shouldSkipMessage s = T.all (`elem` (" \t"::String)) s -sendMessage :: EditMode -> T.Text -> MH ()+sendMessage :: EditMode -> Text -> MH () sendMessage mode msg = case shouldSkipMessage msg of True -> return ()@@ -1918,12 +1963,12 @@ let usrInfo = userInfoFromUser newUser True addNewUser usrInfo -handleNewUsers :: Seq.Seq UserId -> MH ()+handleNewUsers :: Seq UserId -> MH () handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo addNewUsers where getUserInfo session _ = do nUsers <- MM.mmGetUsersByIds newUserIds session let usrInfo u = userInfoFromUser u True- usrList = F.toList nUsers+ usrList = toList nUsers return $ usrInfo <$> usrList addNewUsers :: [UserInfo] -> MH ()
src/State/Common.hs view
@@ -1,20 +1,17 @@ module State.Common where import Prelude ()-import Prelude.Compat+import Prelude.MH import qualified Control.Concurrent.STM as STM import Control.Exception (try)-import Control.Monad.IO.Class (liftIO) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map-import Data.Maybe (isNothing)-import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T-import Lens.Micro.Platform+import Lens.Micro.Platform ((%=), (%~), (.~), traversed) import System.Hclip (setClipboard, ClipboardException(..)) import Network.Mattermost.Endpoints@@ -23,9 +20,6 @@ import Network.Mattermost.Exceptions import Types-import Types.Channels-import Types.Posts-import Types.Messages -- * Mattermost API @@ -179,7 +173,7 @@ postsToMessages f = foldr (addMessage . f) noMessages return msgs where- postMap :: HM.HashMap PostId Message+ postMap :: HashMap PostId Message postMap = HM.fromList [ ( pId , clientPostToMessage (toClientPost x Nothing)@@ -232,20 +226,20 @@ -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list-postInfoMessage :: T.Text -> MH ()+postInfoMessage :: Text -> MH () postInfoMessage err = addClientMessage =<< newClientMessage Informative err -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list-postErrorMessage' :: T.Text -> MH ()+postErrorMessage' :: Text -> MH () postErrorMessage' err = addClientMessage =<< newClientMessage Error err -- | Raise a rich error-mhError :: T.Text -> MH ()+mhError :: Text -> MH () mhError err = do raiseInternalEvent (DisplayError err) -postErrorMessageIO :: T.Text -> ChatState -> IO ChatState+postErrorMessageIO :: Text -> ChatState -> IO ChatState postErrorMessageIO err st = do msg <- newClientMessage Error err let cId = st ^. csCurrentChannelId@@ -259,7 +253,7 @@ asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return () | otherwise = doAsyncChannelMM Normal cId- (\s _ _ -> fmap F.toList (mmGetReactionsForPost (p^.postIdL) s))+ (\s _ _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s)) addReactions addReactions :: ChannelId -> [Reaction] -> MH ()@@ -276,7 +270,7 @@ m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1)) | otherwise = m -copyToClipboard :: T.Text -> MH ()+copyToClipboard :: Text -> MH () copyToClipboard txt = do result <- liftIO (try (setClipboard (T.unpack txt))) case result of
src/State/Editing.hs view
@@ -4,17 +4,14 @@ module State.Editing where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick.Widgets.Edit (Editor, handleEditorEvent, getEditContents, editContentsL) import Brick.Widgets.Edit (applyEdit) import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Arrow import qualified Control.Concurrent.STM as STM-import Control.Monad (when)-import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS-import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -22,7 +19,7 @@ import qualified Data.Text.Zipper.Generic.Words as Z import Data.Time (getCurrentTime) import Graphics.Vty (Event(..), Key(..), Modifier(..))-import Lens.Micro.Platform+import Lens.Micro.Platform ((%=), (.=), (.~), to) import qualified System.Environment as Sys import qualified System.Exit as Sys import qualified System.IO as Sys@@ -266,41 +263,41 @@ tryMM query (return . postMistakes) -editorEmpty :: Editor T.Text a -> Bool+editorEmpty :: Editor Text a -> Bool editorEmpty e = cursorIsAtEnd e && cursorIsAtBeginning e -cursorIsAtEnd :: Editor T.Text a -> Bool+cursorIsAtEnd :: Editor Text a -> Bool cursorIsAtEnd e = let col = snd $ Z.cursorPosition z curLine = Z.currentLine z z = e^.editContentsL in col == T.length curLine -cursorIsAtBeginning :: Editor T.Text a -> Bool+cursorIsAtBeginning :: Editor Text a -> Bool cursorIsAtBeginning e = let col = snd $ Z.cursorPosition z z = e^.editContentsL in col == 0 -cursorAtOneOf :: [Char] -> Editor T.Text a -> Maybe Char+cursorAtOneOf :: [Char] -> Editor Text a -> Maybe Char cursorAtOneOf [] _ = Nothing cursorAtOneOf (c:cs) e = if cursorAtChar c e then Just c else cursorAtOneOf cs e -cursorAtChar :: Char -> Editor T.Text a -> Bool+cursorAtChar :: Char -> Editor Text a -> Bool cursorAtChar ch e = let col = snd $ Z.cursorPosition z curLine = Z.currentLine z z = e^.editContentsL in (T.singleton ch) `T.isPrefixOf` T.drop col curLine -gotoHome :: Z.TextZipper T.Text -> Z.TextZipper T.Text+gotoHome :: Z.TextZipper Text -> Z.TextZipper Text gotoHome = Z.moveCursor (0, 0) -gotoEnd :: Z.TextZipper T.Text -> Z.TextZipper T.Text+gotoEnd :: Z.TextZipper Text -> Z.TextZipper Text gotoEnd z = let zLines = Z.getText z numLines = length zLines
src/State/Messages.hs view
@@ -7,21 +7,18 @@ where -import Control.Monad (unless)-import qualified Data.Foldable as F import Data.Function (on)-import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T-import Lens.Micro.Platform+import Lens.Micro.Platform ((.=), (%=), (%~), (.~), to, at,+ traversed, filtered, ix) import Network.Mattermost import Network.Mattermost.Types import State.Common import TimeUtils import Types-import Types.Channels-import Types.Messages-import Types.Posts+import Prelude ()+import Prelude.MH -- ----------------------------------------------------------------------@@ -65,10 +62,10 @@ -- Flagged messages -loadFlaggedMessages :: Seq.Seq FlaggedPost -> ChatState -> IO ()+loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO () loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True- | fp <- F.toList prefs+ | fp <- toList prefs , flaggedPostStatus fp ]
src/State/PostListOverlay.hs view
@@ -1,15 +1,16 @@ module State.PostListOverlay where -import Control.Monad-import Data.Text (Text)-import Lens.Micro.Platform+import qualified Data.Text as T+import Lens.Micro.Platform ((.=)) import Network.Mattermost.Endpoints import Network.Mattermost.Types+import Prelude ()+import Prelude.MH import State import State.Common import Types-import Types.Messages+import Types.DirectionalSeq (emptyDirSeq) -- | Create a PostListOverlay with the given content description and -- with a specified list of messages.@@ -22,7 +23,7 @@ -- | Clear out the state of a PostListOverlay exitPostListMode :: MH () exitPostListMode = do- csPostListOverlay.postListPosts .= mempty+ csPostListOverlay.postListPosts .= emptyDirSeq csPostListOverlay.postListSelected .= Nothing setMode Main @@ -42,12 +43,15 @@ enterSearchResultPostListMode terms = do session <- getSession tId <- gets myTeamId- enterPostListMode (PostListSearch terms True) noMessages- doAsyncWith Preempt $ do- posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session- return $ do- messages <- messagesFromPosts posts- enterPostListMode (PostListSearch terms False) messages+ case T.null $ T.strip terms of+ True -> postInfoMessage "Search command requires at least one search term."+ False -> do+ enterPostListMode (PostListSearch terms True) noMessages+ doAsyncWith Preempt $ do+ posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session+ return $ do+ messages <- messagesFromPosts posts+ enterPostListMode (PostListSearch terms False) messages -- | Move the selection up in the PostListOverlay, which corresponds -- to finding a chronologically /newer/ message.
src/State/Setup.hs view
@@ -5,20 +5,17 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick.BChan import Brick.Themes (themeToAttrMap, loadCustomizations) import qualified Control.Concurrent.STM as STM import Control.Concurrent.MVar (newMVar) import Control.Exception (catch)-import Control.Monad (forM, when)-import Data.Monoid ((<>))-import qualified Data.Foldable as F-import Data.Maybe (listToMaybe, fromMaybe, fromJust, isNothing)+import Data.Maybe (fromJust) import qualified Data.Sequence as Seq import qualified Data.Text as T-import Lens.Micro.Platform+import Lens.Micro.Platform ((%~)) import System.Exit (exitFailure) import System.FilePath ((</>), isRelative, dropFileName) import System.IO (Handle)@@ -38,7 +35,6 @@ import TimeUtils (lookupLocalTimeZone) import State.Setup.Threads import Types-import Types.Channels import qualified Zipper as Z incompleteCredentials :: Config -> ConnectionInfo@@ -50,6 +46,13 @@ Just (PasswordString s) -> s _ -> "" +convertLoginExceptions :: IO a -> IO (Either AuthenticationException a)+convertLoginExceptions act =+ (Right <$> act)+ `catch` (\e -> return $ Left $ ResolveError e)+ `catch` (\e -> return $ Left $ ConnectError e)+ `catchIOError` (\e -> return $ Left $ AuthIOError e)+ `catch` (\e -> return $ Left $ OtherAuthError e) setupState :: Maybe Handle -> Config -> IO ChatState setupState logFile initialConfig = do@@ -79,11 +82,7 @@ let login = Login { username = cInfo^.ciUsername , password = cInfo^.ciPassword }- result <- (Right <$> mmLogin cd login)- `catch` (\e -> return $ Left $ ResolveError e)- `catch` (\e -> return $ Left $ ConnectError e)- `catchIOError` (\e -> return $ Left $ AuthIOError e)- `catch` (\e -> return $ Left $ OtherAuthError e)+ result <- convertLoginExceptions $ mmLogin cd login -- Update the config with the entered settings so that later, -- when we offer the option of saving the entered credentials to@@ -114,12 +113,12 @@ myTeam <- case configTeam config of Nothing -> do- interactiveTeamSelection $ F.toList teams+ interactiveTeamSelection $ toList teams Just tName -> do- let matchingTeam = listToMaybe $ filter matches $ F.toList teams+ let matchingTeam = listToMaybe $ filter matches $ toList teams matches t = teamName t == tName case matchingTeam of- Nothing -> interactiveTeamSelection (F.toList teams)+ Nothing -> interactiveTeamSelection (toList teams) Just t -> return t userStatusLock <- newMVar ()@@ -197,7 +196,7 @@ -- Since the only channel we are dealing with is by construction the -- last channel, we don't have to consider other cases here:- msgs <- forM (F.toList chans) $ \c -> do+ msgs <- forM (toList chans) $ \c -> do cChannel <- makeClientChannel c return (getId c, cChannel)
src/State/Setup/Threads.hs view
@@ -10,24 +10,18 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick.BChan 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)-import Control.Monad (forever, when, void, forM_)-import Control.Monad.IO.Class (liftIO)+import Control.Exception (SomeException, try, finally, fromException) import Data.List (isInfixOf) import qualified Data.Foldable as F-import qualified Data.Sequence as Seq import qualified Data.Text as T-import Data.Maybe (catMaybes)-import Data.Monoid ((<>)) import Data.Time (getCurrentTime, addUTCTime)-import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)-import Lens.Micro.Platform+import Lens.Micro.Platform ((.=), (%=), (%~), mapped) import System.Exit (ExitCode(ExitSuccess)) import System.IO (hPutStrLn, hFlush) import System.IO.Temp (openTempFile)@@ -42,10 +36,8 @@ import State.Editing (requestSpellCheck) import TimeUtils (lookupLocalTimeZone) import Types-import Types.Users-import Types.Channels -updateUserStatuses :: STM.TVar (Seq.Seq UserId) -> MVar () -> Session -> IO (MH ())+updateUserStatuses :: STM.TVar (Seq UserId) -> MVar () -> Session -> IO (MH ()) updateUserStatuses usersVar lock session = do lockResult <- tryTakeMVar lock users <- STM.atomically $ STM.readTVar usersVar@@ -59,7 +51,7 @@ Just () -> putMVar lock () >> return (return ()) _ -> return $ return () -startUserRefreshThread :: STM.TVar (Seq.Seq UserId) -> MVar () -> Session -> RequestChan -> IO ()+startUserRefreshThread :: STM.TVar (Seq UserId) -> MVar () -> Session -> RequestChan -> IO () startUserRefreshThread usersVar lock session requestChan = void $ forkIO $ forever refresh where seconds = (* (1000 * 1000))@@ -274,9 +266,13 @@ startWork res <- try req case res of- Left e -> when (not $ shouldIgnore e) $- writeBChan eventChan (AsyncErrEvent e)- Right upd -> writeBChan eventChan (RespEvent upd)+ Left e ->+ when (not $ shouldIgnore e) $+ case fromException e of+ Nothing -> writeBChan eventChan (AsyncErrEvent e)+ Just mmErr -> writeBChan eventChan (AsyncMattermostError mmErr)+ 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
src/State/UserListOverlay.hs view
@@ -15,24 +15,22 @@ ) where -import Control.Monad (when)-import Data.Monoid ((<>)) 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 Data.Maybe (fromMaybe)-import Lens.Micro.Platform+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 Types-import Types.Users import State.Common import State (changeChannel, addUserToCurrentChannel) @@ -128,7 +126,7 @@ afterSearchString <- userListSearchString when (searchString /= afterSearchString) resetUserListSearch -userInfoFromPair :: User -> T.Text -> UserInfo+userInfoFromPair :: User -> Text -> UserInfo userInfoFromPair u status = userInfoFromUser u True & uiStatus .~ statusFromText status @@ -234,7 +232,7 @@ -- | Perform an initial request for search results in the specified -- scope.-fetchInitialResults :: TeamId -> UserSearchScope -> Session -> T.Text -> IO (Vec.Vector UserInfo)+fetchInitialResults :: TeamId -> UserSearchScope -> Session -> Text -> IO (Vec.Vector UserInfo) fetchInitialResults = getUserSearchResultsPage 0 searchResultsChunkSize :: Int@@ -248,7 +246,7 @@ -- ^ The scope to search -> Session -- ^ The connection session- -> T.Text+ -> Text -- ^ The search string -> IO (Vec.Vector UserInfo) getUserSearchResultsPage _pageNum myTId scope s searchString = do@@ -278,20 +276,18 @@ , userSearchNotInChannelId = case scope of ChannelNonMembers cId -> Just cId _ -> Nothing- , userSearchTeamId = case scope of- ChannelNonMembers _ -> Just myTId- _ -> Nothing+ , userSearchTeamId = Just myTId } users <- MM.mmSearchUsers query s - let uList = F.toList users+ let uList = toList users uIds = userId <$> uList -- Now fetch status info for the users we got. case null uList of False -> do statuses <- MM.mmGetUserStatusByIds (Seq.fromList uIds) s- let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- F.toList statuses ]+ let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- toList statuses ] usersWithStatus = [ userInfoFromPair u (fromMaybe "" $ HM.lookup (userId u) statusMap) | u <- uList ]@@ -299,6 +295,6 @@ return $ Vec.fromList usersWithStatus True -> return mempty -userListSearchString :: MH T.Text+userListSearchString :: MH Text userListSearchString = (head . E.getEditContents) <$> use (csUserListOverlay.userListSearchInput)
src/TeamSelect.hs view
@@ -3,13 +3,12 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick import Brick.Widgets.List import Brick.Widgets.Center import Brick.Widgets.Border-import Control.Monad.IO.Class (liftIO) import qualified Data.Vector as V import Graphics.Vty import System.Exit (exitSuccess)
src/Themes.hs view
@@ -50,13 +50,10 @@ ) where import Prelude ()-import Prelude.Compat-import Data.List (find)+import Prelude.MH import qualified Data.Map as M import Data.Hashable (hash)-import Data.Maybe (isNothing)-import Data.Monoid ((<>)) import Graphics.Vty import Brick import Brick.Themes@@ -177,11 +174,11 @@ messageSelectStatusAttr = "messageSelectStatus" data InternalTheme =- InternalTheme { internalThemeName :: T.Text+ InternalTheme { internalThemeName :: Text , internalTheme :: Theme } -lookupTheme :: T.Text -> Maybe InternalTheme+lookupTheme :: Text -> Maybe InternalTheme lookupTheme n = find ((== n) . internalThemeName) internalThemes internalThemes :: [InternalTheme]@@ -312,7 +309,7 @@ usernameAttr :: Int -> AttrName usernameAttr i = "username" <> (attrName $ show i) -colorUsername :: T.Text -> T.Text -> Widget a+colorUsername :: Text -> Text -> Widget a colorUsername username display = withDefAttr (usernameAttr h) $ txt (display) where h = hash username `mod` length usernameColors@@ -335,7 +332,7 @@ -- Functions for dealing with Skylighting styles -attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe T.Text+attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe Text attrNameDescription td an = M.lookup an (themeDescriptions td) themeDocs :: ThemeDocumentation
src/TimeUtils.hs view
@@ -13,12 +13,14 @@ 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 (TimeZoneSeries- , localTimeToUTC'+import Data.Time.LocalTime.TimeZone.Series ( localTimeToUTC' , utcToLocalTime') import Network.Mattermost.Types (ServerTime(..)) +import Prelude ()+import Prelude.MH + -- | Get the timezone series that should be used for converting UTC -- times into local times with appropriate DST adjustments. lookupLocalTimeZone :: IO TimeZoneSeries@@ -63,7 +65,7 @@ -- | Local time in displayable format-localTimeText :: T.Text -> LocalTime -> T.Text+localTimeText :: Text -> LocalTime -> Text localTimeText fmt time = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) time
src/Types.hs view
@@ -13,6 +13,7 @@ , InternalEvent(..) , Name(..) , ChannelSelectMatch(..)+ , MatchValue(..) , StartupStateInfo(..) , ConnectionInfo(..) , ciHostname@@ -27,7 +28,6 @@ , Mode(..) , ChannelSelectPattern(..) , PostListContents(..)- , ChannelSelectMap , AuthenticationException(..) , BackgroundInfo(..) , RequestChan@@ -37,6 +37,9 @@ , refreshChannelZipper , getChannelIdsInOrder + , trimUserSigil+ , trimChannelSigil+ , LinkChoice(LinkChoice) , linkUser , linkURL@@ -144,7 +147,7 @@ , mh , mhSuspendAndResume , mhHandleEventLensed- , gets+ , St.gets , requestQuit , clientPostToMessage@@ -155,8 +158,6 @@ , withChannelOrDefault , userList , hasUnread- , channelNameFromMatch- , trimAnySigil , isMine , setUserStatus , myUser@@ -166,6 +167,8 @@ , userIdForUsername , userByDMChannelName , userByUsername+ , channelIdByChannelName+ , channelIdByUsername , channelIdByName , channelByName , userById@@ -189,11 +192,16 @@ , UserSet , ChannelSet , getHighlightSet++ , module Types.Channels+ , module Types.Messages+ , module Types.Posts+ , module Types.Users ) where import Prelude ()-import Prelude.Compat+import Prelude.MH import Brick (EventM, Next) import qualified Brick@@ -201,27 +209,19 @@ import Brick.AttrMap (AttrMap) import Brick.Widgets.Edit (Editor, editor) import Brick.Widgets.List (List, list)-import Control.Applicative ((<|>))-import Control.Monad (when) import qualified Control.Concurrent.STM as STM import Control.Concurrent.MVar (MVar) import Control.Exception (SomeException) import qualified Control.Monad.State as St-import Control.Monad.State (gets) import qualified Data.Foldable as F import qualified Data.Sequence as Seq import qualified Data.Vector as Vec-import Data.HashMap.Strict (HashMap)-import Data.Time (UTCTime)-import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import qualified Data.HashMap.Strict as HM-import Data.List (sort, partition, sortBy)-import Data.Maybe-import Data.Monoid+import Data.List (partition, sortBy) import qualified Data.Set as Set-import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!), (.=)- , (%=), (^?)- , use, _Just, Traversal', preuse, (^..), folded, to, view )+import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=)+ , (%=), (^?), (.~)+ , _Just, Traversal', preuse, (^..), folded, to, view ) import Network.Mattermost (ConnectionData) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses@@ -238,6 +238,7 @@ import InputHistory import Types.Channels+import Types.DirectionalSeq(emptyDirSeq) import Types.KeyEvents import Types.Posts import Types.Messages@@ -249,30 +250,30 @@ -- | A user password is either given to us directly, or a command -- which we execute to find the password. data PasswordSource =- PasswordString T.Text- | PasswordCommand T.Text+ PasswordString Text+ | PasswordCommand Text deriving (Eq, Read, Show) -- | These are all the values that can be read in our configuration -- file. data Config = Config- { configUser :: Maybe T.Text- , configHost :: Maybe T.Text- , configTeam :: Maybe T.Text+ { configUser :: Maybe Text+ , configHost :: Maybe Text+ , configTeam :: Maybe Text , configPort :: Int , configPass :: Maybe PasswordSource- , configTimeFormat :: Maybe T.Text- , configDateFormat :: Maybe T.Text- , configTheme :: Maybe T.Text- , configThemeCustomizationFile :: Maybe T.Text+ , configTimeFormat :: Maybe Text+ , configDateFormat :: Maybe Text+ , configTheme :: Maybe Text+ , configThemeCustomizationFile :: Maybe Text , configSmartBacktick :: Bool- , configURLOpenCommand :: Maybe T.Text+ , configURLOpenCommand :: Maybe Text , configURLOpenCommandInteractive :: Bool , configActivityBell :: Bool , configShowBackground :: BackgroundInfo , configShowMessagePreview :: Bool , configEnableAspell :: Bool- , configAspellDictionary :: Maybe T.Text+ , configAspellDictionary :: Maybe Text , configUnsafeUseHTTP :: Bool , configChannelListWidth :: Int , configShowOlderEdits :: Bool@@ -289,21 +290,24 @@ -- | The 'MMNames' record is for listing human-readable -- names and mapping them back to internal IDs. data MMNames = MMNames- { _cnChans :: [T.Text] -- ^ All channel names- , _cnToChanId :: HashMap T.Text ChannelId- -- ^ Mapping from channel names to 'ChannelId' values- , _cnUsers :: [T.Text] -- ^ All users- , _cnToUserId :: HashMap T.Text UserId+ { _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 } -mkNames :: User -> HM.HashMap UserId User -> Seq.Seq Channel -> MMNames+mkNames :: User -> HashMap UserId User -> Seq Channel -> MMNames mkNames myUser users chans = MMNames { _cnChans = sort [ preferredChannelName c- | c <- F.toList chans, channelType c /= Direct ]- , _cnToChanId = HM.fromList $- [ (preferredChannelName c, channelId c) | c <- F.toList chans ] +++ | 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))@@ -313,7 +317,7 @@ [ (userUsername u, getId u) | u <- HM.elems users ] } where lookupChan n = [ c^.channelIdL- | c <- F.toList chans, c^.channelNameL == n+ | c <- toList chans, c^.channelNameL == n ] -- ** 'MMNames' Lenses@@ -328,12 +332,12 @@ getDMChannelIdsInOrder chanNames getChannelIdsInOrder :: MMNames -> [ChannelId]-getChannelIdsInOrder n = [ (n ^. cnToChanId) HM.! i | i <- n ^. cnChans ]+getChannelIdsInOrder n = [ (n ^. channelNameToChanId) HM.! i | i <- n ^. cnChans ] getDMChannelIdsInOrder :: MMNames -> [ChannelId] getDMChannelIdsInOrder n = [ c | i <- n ^. cnUsers- , c <- maybeToList (HM.lookup i (n ^. cnToChanId))+ , c <- maybeToList (HM.lookup i (n ^. usernameToChanId)) ] -- * Internal Names and References@@ -371,10 +375,10 @@ -- | Our 'ConnectionInfo' contains exactly as much information as is -- necessary to start a connection with a Mattermost server data ConnectionInfo =- ConnectionInfo { _ciHostname :: T.Text+ ConnectionInfo { _ciHostname :: Text , _ciPort :: Int- , _ciUsername :: T.Text- , _ciPassword :: T.Text+ , _ciUsername :: Text+ , _ciPassword :: Text } makeLenses ''ConnectionInfo@@ -393,37 +397,41 @@ data LinkChoice = LinkChoice { _linkTime :: ServerTime , _linkUser :: UserRef- , _linkName :: T.Text- , _linkURL :: T.Text+ , _linkName :: Text+ , _linkURL :: Text , _linkFileId :: Maybe FileId } deriving (Eq, Show) makeLenses ''LinkChoice -- Sigils-normalChannelSigil :: T.Text+normalChannelSigil :: Text normalChannelSigil = "~" -userSigil :: T.Text+userSigil :: Text userSigil = "@" -- ** Channel-matching types data ChannelSelectMatch =- ChannelSelectMatch { nameBefore :: T.Text- , nameMatched :: T.Text- , nameAfter :: T.Text+ ChannelSelectMatch { nameBefore :: Text+ , nameMatched :: Text+ , nameAfter :: Text+ , matchFull :: Text } deriving (Eq, Show) -channelNameFromMatch :: ChannelSelectMatch -> T.Text-channelNameFromMatch (ChannelSelectMatch b m a) = b <> m <> a--data ChannelSelectPattern = CSP MatchType T.Text+data ChannelSelectPattern = CSP MatchType Text deriving (Eq, Show) -data MatchType = Prefix | Suffix | Infix | Equal deriving (Eq, Show)-+data MatchType =+ Prefix+ | Suffix+ | Infix+ | Equal+ | UsersOnly+ | ChannelsOnly+ deriving (Eq, Show) -- * Application State Values @@ -438,8 +446,8 @@ data UserPreferences = UserPreferences { _userPrefShowJoinLeave :: Bool- , _userPrefFlaggedPostList :: Seq.Seq FlaggedPost- , _userPrefGroupChannelPrefs :: HM.HashMap ChannelId Bool+ , _userPrefFlaggedPostList :: Seq FlaggedPost+ , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool } defaultUserPreferences :: UserPreferences@@ -449,7 +457,7 @@ , _userPrefGroupChannelPrefs = mempty } -setUserPreferences :: Seq.Seq Preference -> UserPreferences -> UserPreferences+setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences setUserPreferences = flip (F.foldr go) where go p u | Just fp <- preferenceToFlaggedPost p =@@ -483,9 +491,9 @@ , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap , _crUserStatusLock :: MVar ()- , _crUserIdSet :: STM.TVar (Seq.Seq UserId)+ , _crUserIdSet :: STM.TVar (Seq UserId) , _crConfiguration :: Config- , _crFlaggedPosts :: Set.Set PostId+ , _crFlaggedPosts :: Set PostId , _crUserPreferences :: UserPreferences } @@ -494,16 +502,16 @@ -- as well as history and metadata we need for editing-related -- operations. data ChatEditState = ChatEditState- { _cedEditor :: Editor T.Text Name+ { _cedEditor :: Editor Text Name , _cedEditMode :: EditMode , _cedMultiline :: Bool , _cedInputHistory :: InputHistory- , _cedInputHistoryPosition :: HM.HashMap ChannelId (Maybe Int)- , _cedLastChannelInput :: HM.HashMap ChannelId (T.Text, EditMode)+ , _cedInputHistoryPosition :: HashMap ChannelId (Maybe Int)+ , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode) , _cedCompleter :: Maybe Completer- , _cedYankBuffer :: T.Text+ , _cedYankBuffer :: Text , _cedSpellChecker :: Maybe (Aspell, IO ())- , _cedMisspellings :: Set.Set T.Text+ , _cedMisspellings :: Set Text } data EditMode =@@ -543,8 +551,8 @@ -- | Help topics data HelpTopic =- HelpTopic { helpTopicName :: T.Text- , helpTopicDescription :: T.Text+ HelpTopic { helpTopicName :: Text+ , helpTopicDescription :: Text , helpTopicScreen :: HelpScreen , helpTopicViewportName :: Name }@@ -553,7 +561,7 @@ -- | Mode type for the current contents of the post list overlay data PostListContents = PostListFlagged- | PostListSearch T.Text Bool -- for the query and search status+ | PostListSearch Text Bool -- for the query and search status -- | PostListPinned ChannelId deriving (Eq) @@ -636,7 +644,7 @@ , _csWorkerIsBusy = Nothing , _csJoinChannelList = Nothing , _csMessageSelect = MessageSelectState Nothing- , _csPostListOverlay = PostListOverlayState mempty Nothing+ , _csPostListOverlay = PostListOverlayState emptyDirSeq Nothing , _csUserListOverlay = nullUserListOverlayState , _csClientConfig = Nothing }@@ -659,13 +667,16 @@ -- in Draw.UserListOverlay. list UserListSearchResults rs 1 -type ChannelSelectMap = HM.HashMap T.Text ChannelSelectMatch+data MatchValue =+ UserMatch Text+ | ChannelMatch Text+ deriving (Eq, Show) data ChannelSelectState =- ChannelSelectState { _channelSelectInput :: T.Text- , _channelMatches :: ChannelSelectMap- , _userMatches :: ChannelSelectMap- , _selectedMatch :: T.Text+ ChannelSelectState { _channelSelectInput :: Text+ , _channelMatches :: [ChannelSelectMatch]+ , _userMatches :: [ChannelSelectMatch]+ , _selectedMatch :: Maybe MatchValue } emptyChannelSelectState :: ChannelSelectState@@ -673,7 +684,7 @@ ChannelSelectState { _channelSelectInput = "" , _channelMatches = mempty , _userMatches = mempty- , _selectedMatch = ""+ , _selectedMatch = Nothing } data MessageSelectState =@@ -687,7 +698,7 @@ data UserListOverlayState = UserListOverlayState { _userListSearchResults :: List Name UserInfo , _userListSelected :: Maybe PostId- , _userListSearchInput :: Editor T.Text Name+ , _userListSearchInput :: Editor Text Name , _userListSearchScope :: UserSearchScope , _userListSearching :: Bool , _userListRequestingMore :: Bool@@ -773,6 +784,8 @@ -- ^ 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@@ -791,7 +804,7 @@ -- ^ MH-internal events data InternalEvent- = DisplayError T.Text+ = DisplayError Text -- ^ Display a generic error message to the user deriving (Eq, Show) @@ -873,35 +886,58 @@ = st^.csPostMap.at(pId) | otherwise = Nothing -setUserStatus :: UserId -> T.Text -> MH ()+setUserStatus :: UserId -> Text -> MH () setUserStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) -nicknameForUserId :: UserId -> ChatState -> Maybe T.Text+nicknameForUserId :: UserId -> ChatState -> Maybe Text nicknameForUserId uId st = _uiNickName =<< findUserById uId (st^.csUsers) -usernameForUserId :: UserId -> ChatState -> Maybe T.Text+usernameForUserId :: UserId -> ChatState -> Maybe Text usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers) -displaynameForUserId :: UserId -> ChatState -> Maybe T.Text+displaynameForUserId :: UserId -> ChatState -> Maybe Text displaynameForUserId uId st | useNickname st = nicknameForUserId uId st <|> usernameForUserId uId st | otherwise = usernameForUserId uId st -userIdForUsername :: T.Text -> ChatState -> Maybe UserId-userIdForUsername name st = st^.csNames.cnToUserId.at name -channelIdByName :: T.Text -> ChatState -> Maybe ChannelId+userIdForUsername :: Text -> ChatState -> Maybe UserId+userIdForUsername name st = st^.csNames.cnToUserId.at (trimUserSigil name)++channelIdByChannelName :: Text -> ChatState -> Maybe ChannelId+channelIdByChannelName name st =+ HM.lookup (trimChannelSigil name) $ st^.csNames.channelNameToChanId++-- | Get a channel ID by username or channel name. Returns (channel+-- match, user match). Note that this returns multiple results because+-- it's possible for there to be a match for both users and channels.+-- Note that this function uses sigils on the input to guarantee clash+-- avoidance, i.e., that if the user sigil is present in the input,+-- only users will be searched. This allows callers (or the user) to+-- disambiguate by sigil, which may be necessary in cases where an input+-- with no sigil finds multiple matches.+channelIdByName :: Text -> ChatState -> (Maybe ChannelId, Maybe ChannelId) channelIdByName name st =+ let uMatch = channelIdByUsername name st+ cMatch = channelIdByChannelName name st+ matches =+ if | userSigil `T.isPrefixOf` name -> (Nothing, uMatch)+ | normalChannelSigil `T.isPrefixOf` name -> (cMatch, Nothing)+ | otherwise -> (cMatch, uMatch)+ in matches++channelIdByUsername :: Text -> ChatState -> Maybe ChannelId+channelIdByUsername name st = let userInfos = st^.csUsers.to allUsers uName = if useNickname st then maybe name (view uiName) $ findUserByNickname userInfos name else name- nameToChanId = st^.csNames.cnToChanId- in HM.lookup (trimAnySigil uName) nameToChanId+ nameToChanId = st^.csNames.usernameToChanId+ in HM.lookup (trimUserSigil uName) nameToChanId useNickname :: ChatState -> Bool useNickname st = case st^?csClientConfig._Just.to clientConfigTeammateNameDisplay of@@ -910,23 +946,21 @@ _ -> False -channelByName :: T.Text -> ChatState -> Maybe ClientChannel+channelByName :: Text -> ChatState -> Maybe ClientChannel channelByName n st = do- let userInfos = st^.csUsers.to allUsers- uName = if useNickname st- then- maybe n (view uiName)- $ findUserByNickname userInfos n- else n- cId <- channelIdByName uName st+ cId <- channelIdByChannelName n st findChannelById cId (st^.csChannels) -trimAnySigil :: T.Text -> T.Text-trimAnySigil n+trimChannelSigil :: Text -> Text+trimChannelSigil n | normalChannelSigil `T.isPrefixOf` n = T.tail n- | userSigil `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@@ -939,18 +973,20 @@ userSet <- use (csResources.crUserIdSet) St.liftIO $ STM.atomically $ STM.modifyTVar userSet $ (uid Seq.<|) -setUserIdSet :: Seq.Seq UserId -> MH ()+setUserIdSet :: Seq UserId -> MH () setUserIdSet ids = do userSet <- use (csResources.crUserIdSet) St.liftIO $ STM.atomically $ STM.writeTVar userSet ids -addChannelName :: Type -> ChannelId -> T.Text -> MH ()+addChannelName :: Type -> ChannelId -> Text -> MH () addChannelName chType cid name = do- csNames.cnToChanId.at(name) .= Just cid+ case chType of+ Direct -> csNames.usernameToChanId.at(name) .= Just cid+ _ -> csNames.channelNameToChanId.at(name) .= Just cid -- For direct channels the username is already in the user list so -- do nothing- existingNames <- gets allChannelNames+ existingNames <- St.gets allChannelNames when (chType /= Direct && (not $ name `elem` existingNames)) $ csNames.cnChans %= (sort . (name:)) @@ -958,16 +994,16 @@ channelMentionCount cId st = maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) -allChannelNames :: ChatState -> [T.Text]+allChannelNames :: ChatState -> [Text] allChannelNames st = st^.csNames.cnChans -allUsernames :: ChatState -> [T.Text]+allUsernames :: ChatState -> [Text] allUsernames st = st^.csNames.cnChans -removeChannelName :: T.Text -> MH ()+removeChannelName :: Text -> MH () removeChannelName name = do -- Flush cnToChanId- csNames.cnToChanId.at name .= Nothing+ csNames.channelNameToChanId.at name .= Nothing -- Flush cnChans csNames.cnChans %= filter (/= name) @@ -1009,8 +1045,8 @@ -- the type parameter represents the argument structure. data CmdArgs :: * -> * where NoArg :: CmdArgs ()- LineArg :: T.Text -> CmdArgs T.Text- TokenArg :: T.Text -> CmdArgs rest -> CmdArgs (T.Text, rest)+ 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@@ -1019,14 +1055,14 @@ -- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec' -- implementation with a name and a description. data Cmd = forall a. Cmd- { cmdName :: T.Text- , cmdDescr :: T.Text+ { cmdName :: Text+ , cmdDescr :: Text , cmdArgSpec :: CmdArgs a , cmdAction :: CmdExec a } -- | Helper function to extract the name out of a 'Cmd' value-commandName :: Cmd -> T.Text+commandName :: Cmd -> Text commandName (Cmd name _ _ _ ) = name -- * Channel Updates and Notifications@@ -1058,7 +1094,7 @@ myUser :: ChatState -> User myUser st = st^.csMe -userByDMChannelName :: T.Text+userByDMChannelName :: Text -- ^ the dm channel name -> UserId -- ^ me@@ -1068,7 +1104,7 @@ userByDMChannelName name self st = findUserByDMChannelName (st^.csUsers) name self -userByUsername :: T.Text -> ChatState -> Maybe UserInfo+userByUsername :: Text -> ChatState -> Maybe UserInfo userByUsername name st = do uId <- userIdForUsername name st userById uId st@@ -1078,7 +1114,7 @@ where cmp = compareUserInfo uiName dmHasUnread u =- case st^.csNames.cnToChanId.at(u^.uiName) of+ case st^.csNames.usernameToChanId.at(u^.uiName) of Nothing -> False Just cId | (st^.csCurrentChannelId) == cId -> False@@ -1096,12 +1132,12 @@ -- * HighlightSet -type UserSet = Set.Set T.Text-type ChannelSet = Set.Set T.Text+type UserSet = Set Text+type ChannelSet = Set Text data HighlightSet = HighlightSet- { hUserSet :: Set.Set T.Text- , hChannelSet :: Set.Set T.Text+ { hUserSet :: Set Text+ , hChannelSet :: Set Text } getHighlightSet :: ChatState -> HighlightSet
src/Types/Channels.hs view
@@ -44,11 +44,10 @@ ) where -import Control.Monad.IO.Class (MonadIO) import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import Data.Time.Clock (UTCTime)-import Lens.Micro.Platform+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(..)@@ -64,6 +63,8 @@ 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 -- * Channel representations @@ -77,7 +78,7 @@ } -- Get a channel's name, depending on its type-preferredChannelName :: Channel -> T.Text+preferredChannelName :: Channel -> Text preferredChannelName ch | channelType ch == Group = channelDisplayName ch | otherwise = channelName ch@@ -156,11 +157,11 @@ -- ^ The current number of unread mentions , _cdUpdated :: ServerTime -- ^ The last time a message showed up in the channel- , _cdName :: T.Text+ , _cdName :: Text -- ^ The name of the channel- , _cdHeader :: T.Text+ , _cdHeader :: Text -- ^ The header text of a channel- , _cdPurpose :: T.Text+ , _cdPurpose :: Text -- ^ The stated purpose of the channel , _cdType :: Type -- ^ The type of a channel: public, private, or DM@@ -197,7 +198,7 @@ -- ** Manage the collection of all Channels -- | Define a binary kinded type to allow derivation of functor.-newtype AllMyChannels a = AllChannels { _ofChans :: HM.HashMap ChannelId a }+newtype AllMyChannels a = AllChannels { _ofChans :: HashMap ChannelId a } deriving (Functor, Foldable, Traversable) -- | Define the exported typename which universally binds the
src/Types/DirectionalSeq.hs view
@@ -12,8 +12,9 @@ module Types.DirectionalSeq where -import Data.Monoid import qualified Data.Sequence as Seq+import Prelude ()+import Prelude.MH data Chronological@@ -23,14 +24,16 @@ instance SeqDirection Retrograde data SeqDirection dir => DirectionalSeq dir a =- DSeq { dseq :: Seq.Seq a }+ DSeq { dseq :: Seq a } deriving (Show, Functor, Foldable, Traversable) -instance SeqDirection a => Monoid (DirectionalSeq a e) where- mempty = DSeq mempty- mappend a b = DSeq $ mappend (dseq a) (dseq b)+emptyDirSeq :: DirectionalSeq dir a+emptyDirSeq = DSeq mempty -onDirectedSeq :: SeqDirection dir => (Seq.Seq a -> Seq.Seq b)+appendDirSeq :: DirectionalSeq dir a -> DirectionalSeq dir a -> DirectionalSeq dir a+appendDirSeq a b = DSeq $ mappend (dseq a) (dseq b)++onDirectedSeq :: SeqDirection dir => (Seq a -> Seq b) -> DirectionalSeq dir a -> DirectionalSeq dir b onDirectedSeq f = DSeq . f . dseq @@ -57,7 +60,7 @@ then (ml2 <> Seq.take 1 el, Seq.drop 1 el) else (ml2, el) (ml3, rval) = op $ DSeq ml2'- in (DSeq bl <> ml3 <> DSeq el', rval)+ in (DSeq bl `appendDirSeq` ml3 `appendDirSeq` DSeq el', rval) -- | dirSeqBreakl splits the DirectionalSeq into a tuple where the -- first element is the (possibly empty) DirectionalSeq of all
src/Types/KeyEvents.hs view
@@ -25,9 +25,10 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Graphics.Vty as Vty-import Text.Read (readMaybe)-import Data.Monoid ((<>)) +import Prelude ()+import Prelude.MH+ -- | This enum represents all the possible key events a user might -- want to use. data KeyEvent@@ -146,7 +147,7 @@ type KeyConfig = M.Map KeyEvent BindingState -parseBinding :: T.Text -> Either String Binding+parseBinding :: Text -> Either String Binding parseBinding kb = go (T.splitOn "-" $ T.toLower kb) [] where go [k] mods = do key <- pKey k@@ -199,11 +200,11 @@ Just i -> return (Vty.KFun i) | otherwise = Left ("Unknown keybinding: " ++ show t) -ppBinding :: Binding -> T.Text+ppBinding :: Binding -> Text ppBinding (Binding mods k) = T.intercalate "-" $ (ppMod <$> mods) <> [ppKey k] -ppKey :: Vty.Key -> T.Text+ppKey :: Vty.Key -> Text ppKey (Vty.KChar c) = ppChar c ppKey (Vty.KFun n) = "F" <> (T.pack $ show n) ppKey Vty.KBackTab = "BackTab"@@ -230,7 +231,7 @@ ppKey Vty.KBegin = "Begin" ppKey Vty.KMenu = "Menu" -nonCharKeys :: [T.Text]+nonCharKeys :: [Text] nonCharKeys = map ppKey [ Vty.KBackTab, Vty.KEsc, Vty.KBS, Vty.KEnter, Vty.KUp, Vty.KDown , Vty.KLeft, Vty.KRight, Vty.KHome, Vty.KEnd, Vty.KPageDown@@ -239,31 +240,31 @@ , Vty.KBegin, Vty.KMenu ] -ppChar :: Char -> T.Text+ppChar :: Char -> Text ppChar '\t' = "Tab" ppChar ' ' = "Space" ppChar c = T.singleton c -ppMod :: Vty.Modifier -> T.Text+ppMod :: Vty.Modifier -> Text ppMod Vty.MMeta = "M" ppMod Vty.MAlt = "A" ppMod Vty.MCtrl = "C" ppMod Vty.MShift = "S" -parseBindingList :: T.Text -> Either String BindingState+parseBindingList :: Text -> Either String BindingState parseBindingList t = if T.toLower t == "unbound" then return Unbound else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," t) -keyEventFromName :: T.Text -> Either String KeyEvent+keyEventFromName :: Text -> Either String KeyEvent keyEventFromName t = let mapping = M.fromList [ (keyEventName e, e) | e <- allEvents ] in case M.lookup t mapping of Just e -> return e Nothing -> Left ("Unknown event: " ++ show t) -keyEventName :: KeyEvent -> T.Text+keyEventName :: KeyEvent -> Text keyEventName ev = case ev of QuitEvent -> "quit" VtyRefreshEvent -> "vty-refresh"
src/Types/Messages.hs view
@@ -74,16 +74,15 @@ where import Cheapskate (Blocks)-import Control.Applicative import qualified Data.Map.Strict as Map-import Data.Maybe (isJust, isNothing) import Data.Sequence as Seq-import qualified Data.Text as T import Data.Tuple-import Lens.Micro.Platform+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@@ -97,10 +96,10 @@ , _mType :: MessageType , _mPending :: Bool , _mDeleted :: Bool- , _mAttachments :: Seq.Seq Attachment+ , _mAttachments :: Seq Attachment , _mInReplyToMsg :: ReplyState , _mPostId :: Maybe PostId- , _mReactions :: Map.Map T.Text Int+ , _mReactions :: Map.Map Text Int , _mOriginalPost :: Maybe Post , _mFlagged :: Bool , _mChannelId :: Maybe ChannelId@@ -135,7 +134,7 @@ -- | There may be no user (usually an internal message), a reference -- to a user (by Id), or the server may have supplied a specific -- username (often associated with bots).-data UserRef = NoUser | UserI UserId | UserOverride T.Text+data UserRef = NoUser | UserI UserId | UserOverride Text deriving (Eq, Show, Ord) -- | The 'ReplyState' of a message represents whether a message@@ -166,7 +165,7 @@ , _mChannelId = Nothing } -newMessageOfType :: T.Text -> MessageType -> ServerTime -> Message+newMessageOfType :: Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message { _mText = getBlocks text , _mUser = NoUser
src/Types/Posts.hs view
@@ -46,22 +46,22 @@ import Cheapskate (Blocks) import qualified Cheapskate as C-import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Map.Strict as Map-import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock (getCurrentTime)-import Lens.Micro.Platform ((^.), makeLenses)+import Lens.Micro.Platform (makeLenses) import Network.Mattermost.Types import Network.Mattermost.Lenses+import Prelude ()+import Prelude.MH -- * Client Messages -- | A 'ClientMessage' is a message given to us by our client, -- like help text or an error message. data ClientMessage = ClientMessage- { _cmText :: T.Text+ { _cmText :: Text , _cmDate :: ServerTime , _cmType :: ClientMessageType } deriving (Eq, Show)@@ -74,7 +74,7 @@ -- messages should follow them), so this is a special place where -- there is an assumed approximation of equality between local time -- and server time.-newClientMessage :: (MonadIO m) => ClientMessageType -> T.Text -> m ClientMessage+newClientMessage :: (MonadIO m) => ClientMessageType -> Text -> m ClientMessage newClientMessage ty msg = do now <- liftIO getCurrentTime return (ClientMessage msg (ServerTime now) ty)@@ -101,28 +101,28 @@ data ClientPost = ClientPost { _cpText :: Blocks , _cpUser :: Maybe UserId- , _cpUserOverride :: Maybe T.Text+ , _cpUserOverride :: Maybe Text , _cpDate :: ServerTime , _cpType :: ClientPostType , _cpPending :: Bool , _cpDeleted :: Bool- , _cpAttachments :: Seq.Seq Attachment+ , _cpAttachments :: Seq Attachment , _cpInReplyToPost :: Maybe PostId , _cpPostId :: PostId , _cpChannelId :: ChannelId- , _cpReactions :: Map.Map T.Text Int+ , _cpReactions :: Map.Map Text Int , _cpOriginalPost :: Post } deriving (Show) -- | An attachment has a very long URL associated, as well as -- an actual file URL data Attachment = Attachment- { _attachmentName :: T.Text- , _attachmentURL :: T.Text+ { _attachmentName :: Text+ , _attachmentURL :: Text , _attachmentFileId :: FileId } deriving (Eq, Show) -mkAttachment :: T.Text -> T.Text -> FileId -> Attachment+mkAttachment :: Text -> Text -> FileId -> Attachment mkAttachment = Attachment -- | A Mattermost 'Post' value can represent either a normal@@ -138,7 +138,7 @@ -- ** Creating 'ClientPost' Values -- | Parse text as Markdown and extract the AST-getBlocks :: T.Text -> Blocks+getBlocks :: Text -> Blocks getBlocks s = bs where C.Doc _ bs = C.markdown C.def s -- | Determine the internal 'PostType' based on a 'Post'@@ -157,7 +157,7 @@ -- | Find out whether a 'Post' is from a @/me@ command postIsEmote :: Post -> Bool postIsEmote p =- and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::T.Text)+ and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::Text) , ("*" `T.isPrefixOf` postMessage p) , ("*" `T.isSuffixOf` postMessage p) ]@@ -173,7 +173,7 @@ p^.postTypeL == PostTypeLeaveChannel -- | Undo the automatic formatting of posts generated by @/me@-commands-unEmote :: ClientPostType -> T.Text -> T.Text+unEmote :: ClientPostType -> Text -> Text unEmote Emote t = if "*" `T.isPrefixOf` t && "*" `T.isSuffixOf` t then T.init $ T.tail t else t
src/Types/Users.hs view
@@ -32,29 +32,27 @@ ) where -import Data.Foldable (find)-import Data.Semigroup ((<>), Max(..))+import Data.Semigroup (Max(..)) import qualified Data.HashMap.Strict as HM-import Data.List (sort)-import Data.Maybe (listToMaybe, maybeToList) import qualified Data.Text as T-import Data.Time (UTCTime)-import Lens.Micro.Platform+import Lens.Micro.Platform ((%~), makeLenses, ix) import Network.Mattermost.Types (Id(Id), UserId(..), User(..), idString)+import Prelude ()+import Prelude.MH -- * 'UserInfo' Values -- | A 'UserInfo' value represents everything we need to know at -- runtime about a user data UserInfo = UserInfo- { _uiName :: T.Text+ { _uiName :: Text , _uiId :: UserId , _uiStatus :: UserStatus , _uiInTeam :: Bool- , _uiNickName :: Maybe T.Text- , _uiFirstName :: T.Text- , _uiLastName :: T.Text- , _uiEmail :: T.Text+ , _uiNickName :: Maybe Text+ , _uiFirstName :: Text+ , _uiLastName :: Text+ , _uiEmail :: Text , _uiDeleted :: Bool } deriving (Eq, Show) @@ -85,10 +83,10 @@ | Away | Offline | DoNotDisturb- | Other T.Text+ | Other Text deriving (Eq, Show) -statusFromText :: T.Text -> UserStatus+statusFromText :: Text -> UserStatus statusFromText t = case t of "online" -> Online "offline" -> Offline@@ -103,7 +101,7 @@ -- ** Manage the collection of all Users -- | Define a binary kinded type to allow derivation of functor.-newtype AllMyUsers a = AllUsers { _ofUsers :: HM.HashMap UserId a }+newtype AllMyUsers a = AllUsers { _ofUsers :: HashMap UserId a } deriving Functor makeLenses ''AllMyUsers@@ -156,7 +154,7 @@ -- | Get the User information given the user's name. This is an exact -- match on the username field, not necessarly the presented name.-findUserByName :: Users -> T.Text -> Maybe (UserId, UserInfo)+findUserByName :: Users -> Text -> Maybe (UserId, UserInfo) findUserByName allusers name = case filter ((== name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of (usr : []) -> Just usr@@ -164,7 +162,7 @@ -- | Get the User information given the user's name. This is an exact -- match on the nickname field, not necessarily the presented name.-findUserByNickname :: [UserInfo] -> T.Text -> Maybe UserInfo+findUserByNickname :: [UserInfo] -> Text -> Maybe UserInfo findUserByNickname uList nick = find (nickCheck nick) uList where@@ -175,7 +173,7 @@ modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users modifyUserById uId f = ofUsers.ix(uId) %~ f -getDMChannelName :: UserId -> UserId -> T.Text+getDMChannelName :: UserId -> UserId -> Text getDMChannelName me you = cname where [loUser, hiUser] = sort $ idString <$> [ you, me ]@@ -186,7 +184,7 @@ -- is but neither user ID in the name matches the current user's ID. userIdForDMChannel :: UserId -- ^ My user ID- -> T.Text+ -> Text -- ^ The channel name -> Maybe UserId userIdForDMChannel me chanName =@@ -200,7 +198,7 @@ _ -> Nothing findUserByDMChannelName :: Users- -> T.Text -- ^ the dm channel name+ -> Text -- ^ the dm channel name -> UserId -- ^ me -> Maybe UserInfo -- ^ you findUserByDMChannelName users dmchan me = listToMaybe
src/Zipper.hs view
@@ -1,7 +1,6 @@ module Zipper ( Zipper , fromList- , toList , focus , focusL , left@@ -16,15 +15,20 @@ where import Prelude ()-import Prelude.Compat+import Prelude.MH -import Lens.Micro.Platform (Lens, lens, ix, (&), (.~))+import qualified Data.Foldable as F +import Lens.Micro.Platform (Lens, lens, ix, (.~))+ data Zipper a = Zipper { zFocus :: Int , zElems :: [a] } +instance F.Foldable Zipper where+ foldMap f = foldMap f . zElems+ -- Move the focus one element to the left left :: Zipper a -> Zipper a left z = z { zFocus = (zFocus z - 1) `mod` length (zElems z) }@@ -53,9 +57,6 @@ -- Turn a list into a wraparound zipper, focusing on the head fromList :: [a] -> Zipper a fromList xs = Zipper { zFocus = 0, zElems = xs }--toList :: Zipper a -> [a]-toList = zElems -- Shift the focus until a given element is found, or return the -- same zipper if none applies
test/test_messages.hs view
@@ -5,28 +5,27 @@ import Control.Exception import Data.Function (on)-import Data.List (intercalate, sortBy, sort)+import Data.List (sortBy) import qualified Data.List.UniqueUnsorted as U import qualified Data.Map as Map-import Data.Maybe (isNothing, fromJust, isJust, catMaybes)-import Data.Monoid ((<>))+import Data.Maybe (fromJust) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Calendar (Day(..)) import Data.Time.Clock (UTCTime(..), getCurrentTime , secondsToDiffTime)-import Lens.Micro.Platform import Message_QCA import Network.Mattermost.Types import System.Exit import Test.QuickCheck.Checkers-import Test.QuickCheck.Classes import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import TimeUtils+import Types.DirectionalSeq import Types.Messages import Types.Posts+import Prelude.MH main :: IO () main = defaultMain tests `catch` (\e -> do@@ -111,15 +110,15 @@ $ \(x, y) -> let m1 = makeMsgs [x, y] m2 = noMessages- in (2 == (length $ m1 <> m2) &&- 2 == (length $ m2 <> m1))+ in (2 == (length $ m1 `appendDirSeq` m2) &&+ 2 == (length $ m2 `appendDirSeq` m1)) , testProperty "join one to many" $ \(x, y, z) -> let l1 = setDateOrderMessages [x, y] m1 = makeMsgs l1 m2 = addMessage z noMessages- j2 = m2 <> m1+ j2 = m2 `appendDirSeq` m1 in idlist [z, x, y] === idlist j2 , testProperty "join many to one"@@ -127,7 +126,7 @@ let l1 = setDateOrderMessages [x, y] m1 = makeMsgs l1 m2 = addMessage z noMessages- j1 = m1 <> m2+ j1 = m1 `appendDirSeq` m2 in idlist [x, y, z] === idlist j1 , testProperty "join to many"@@ -140,8 +139,8 @@ -- no date relationship between the -- members l1 and l2 and mappend doesn't -- enforce one.- j1 = m1 <> m2- j2 = m2 <> m1+ j1 = m1 `appendDirSeq` m2+ j2 = m2 `appendDirSeq` m1 in (4 == (length j1) && 4 == (length j2) && idlist (l1 <> l2) == idlist j1 &&@@ -875,11 +874,20 @@ ] +monoid' :: (Show t, Arbitrary t, EqProp t) => t -> (t -> t -> t) -> TestBatch+monoid' mempty' mappend' =+ ( "monoid"+ , [ ("left identity", leftId mappend' mempty')+ , ("right identity", rightId mappend' mempty')+ , ("associativity" , isAssoc mappend')+ ]+ )+ instanceTests :: TestTree instanceTests = testGroup "Messages Instances" $ map tastyBatch- [ (monoid (undefined :: Messages))- , (monoid (undefined :: RetrogradeMessages))+ [ (monoid' (emptyDirSeq :: Messages) appendDirSeq)+ , (monoid' (emptyDirSeq :: RetrogradeMessages) appendDirSeq) ] instance EqProp Messages where