diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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) diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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) diff --git a/src/Completion.hs b/src/Completion.hs --- a/src/Completion.hs +++ b/src/Completion.hs @@ -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) diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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) && diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -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) diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -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 diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -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 diff --git a/src/Draw/DeleteChannelConfirm.hs b/src/Draw/DeleteChannelConfirm.hs --- a/src/Draw/DeleteChannelConfirm.hs +++ b/src/Draw/DeleteChannelConfirm.hs @@ -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 diff --git a/src/Draw/JoinChannel.hs b/src/Draw/JoinChannel.hs --- a/src/Draw/JoinChannel.hs +++ b/src/Draw/JoinChannel.hs @@ -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 = diff --git a/src/Draw/LeaveChannelConfirm.hs b/src/Draw/LeaveChannelConfirm.hs --- a/src/Draw/LeaveChannelConfirm.hs +++ b/src/Draw/LeaveChannelConfirm.hs @@ -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 diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -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 ] diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -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 diff --git a/src/Draw/PostListOverlay.hs b/src/Draw/PostListOverlay.hs --- a/src/Draw/PostListOverlay.hs +++ b/src/Draw/PostListOverlay.hs @@ -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] diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -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) " " diff --git a/src/Draw/UserListOverlay.hs b/src/Draw/UserListOverlay.hs --- a/src/Draw/UserListOverlay.hs +++ b/src/Draw/UserListOverlay.hs @@ -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 diff --git a/src/Draw/Util.hs b/src/Draw/Util.hs --- a/src/Draw/Util.hs +++ b/src/Draw/Util.hs @@ -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) diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -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 diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -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 diff --git a/src/Events/ChannelSelect.hs b/src/Events/ChannelSelect.hs --- a/src/Events/ChannelSelect.hs +++ b/src/Events/ChannelSelect.hs @@ -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 diff --git a/src/Events/DeleteChannelConfirm.hs b/src/Events/DeleteChannelConfirm.hs --- a/src/Events/DeleteChannelConfirm.hs +++ b/src/Events/DeleteChannelConfirm.hs @@ -1,7 +1,7 @@ module Events.DeleteChannelConfirm where import Prelude () -import Prelude.Compat +import Prelude.MH import qualified Graphics.Vty as Vty diff --git a/src/Events/JoinChannel.hs b/src/Events/JoinChannel.hs --- a/src/Events/JoinChannel.hs +++ b/src/Events/JoinChannel.hs @@ -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) diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -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] diff --git a/src/Events/LeaveChannelConfirm.hs b/src/Events/LeaveChannelConfirm.hs --- a/src/Events/LeaveChannelConfirm.hs +++ b/src/Events/LeaveChannelConfirm.hs @@ -1,7 +1,7 @@ module Events.LeaveChannelConfirm where import Prelude () -import Prelude.Compat +import Prelude.MH import qualified Graphics.Vty as Vty diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -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 ) diff --git a/src/Events/MessageSelect.hs b/src/Events/MessageSelect.hs --- a/src/Events/MessageSelect.hs +++ b/src/Events/MessageSelect.hs @@ -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 diff --git a/src/Events/PostListOverlay.hs b/src/Events/PostListOverlay.hs --- a/src/Events/PostListOverlay.hs +++ b/src/Events/PostListOverlay.hs @@ -1,6 +1,8 @@ module Events.PostListOverlay where import qualified Graphics.Vty as Vty +import Prelude () +import Prelude.MH import Types import Events.Keybindings diff --git a/src/Events/ShowHelp.hs b/src/Events/ShowHelp.hs --- a/src/Events/ShowHelp.hs +++ b/src/Events/ShowHelp.hs @@ -1,7 +1,7 @@ module Events.ShowHelp where import Prelude () -import Prelude.Compat +import Prelude.MH import Brick import qualified Graphics.Vty as Vty diff --git a/src/Events/UrlSelect.hs b/src/Events/UrlSelect.hs --- a/src/Events/UrlSelect.hs +++ b/src/Events/UrlSelect.hs @@ -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 diff --git a/src/Events/UserListOverlay.hs b/src/Events/UserListOverlay.hs --- a/src/Events/UserListOverlay.hs +++ b/src/Events/UserListOverlay.hs @@ -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) diff --git a/src/FilePaths.hs b/src/FilePaths.hs --- a/src/FilePaths.hs +++ b/src/FilePaths.hs @@ -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 diff --git a/src/HelpTopics.hs b/src/HelpTopics.hs --- a/src/HelpTopics.hs +++ b/src/HelpTopics.hs @@ -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 diff --git a/src/IOUtil.hs b/src/IOUtil.hs --- a/src/IOUtil.hs +++ b/src/IOUtil.hs @@ -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) diff --git a/src/InputHistory.hs b/src/InputHistory.hs --- a/src/InputHistory.hs +++ b/src/InputHistory.hs @@ -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) diff --git a/src/LastRunState.hs b/src/LastRunState.hs --- a/src/LastRunState.hs +++ b/src/LastRunState.hs @@ -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. diff --git a/src/Login.hs b/src/Login.hs --- a/src/Login.hs +++ b/src/Login.hs @@ -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 _) = diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,9 +1,8 @@ module Main where import Prelude () -import Prelude.Compat +import Prelude.MH -import Data.Monoid ((<>)) import System.Exit (exitFailure) import Config diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -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 diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -3,7 +3,7 @@ module Options where import Prelude () -import Prelude.Compat +import Prelude.MH import Data.Version (showVersion) import Development.GitRev diff --git a/src/Prelude/MH.hs b/src/Prelude/MH.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/MH.hs @@ -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 diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -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" diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -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 () diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -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 diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -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 diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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 ] diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -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. diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -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) diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -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 diff --git a/src/State/UserListOverlay.hs b/src/State/UserListOverlay.hs --- a/src/State/UserListOverlay.hs +++ b/src/State/UserListOverlay.hs @@ -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) diff --git a/src/TeamSelect.hs b/src/TeamSelect.hs --- a/src/TeamSelect.hs +++ b/src/TeamSelect.hs @@ -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) diff --git a/src/Themes.hs b/src/Themes.hs --- a/src/Themes.hs +++ b/src/Themes.hs @@ -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 diff --git a/src/TimeUtils.hs b/src/TimeUtils.hs --- a/src/TimeUtils.hs +++ b/src/TimeUtils.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -44,11 +44,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 diff --git a/src/Types/DirectionalSeq.hs b/src/Types/DirectionalSeq.hs --- a/src/Types/DirectionalSeq.hs +++ b/src/Types/DirectionalSeq.hs @@ -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 diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -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" diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -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 diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -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 diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -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 diff --git a/src/Zipper.hs b/src/Zipper.hs --- a/src/Zipper.hs +++ b/src/Zipper.hs @@ -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 diff --git a/test/test_messages.hs b/test/test_messages.hs --- a/test/test_messages.hs +++ b/test/test_messages.hs @@ -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