{-# LANGUAGE MultiWayIf #-}
module Matterhorn.State.ChannelSelect
( beginChannelSelect
, updateChannelSelectMatches
, channelSelectNext
, channelSelectPrevious
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick.Widgets.Edit ( getEditContents )
import Data.Char ( isUpper )
import qualified Data.Text as T
import Lens.Micro.Platform
import qualified Network.Mattermost.Types as MM
import Matterhorn.Constants ( userSigil, normalChannelSigil )
import Matterhorn.Types
import qualified Matterhorn.Zipper as Z
beginChannelSelect :: MM.TeamId -> MH ()
beginChannelSelect :: TeamId -> MH ()
beginChannelSelect TeamId
tId = do
TeamId -> Mode -> MH ()
pushMode TeamId
tId Mode
ChannelSelect
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState ChannelSelectState
tsChannelSelectState forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= TeamId -> ChannelSelectState
emptyChannelSelectState TeamId
tId
TeamId -> MH ()
updateChannelSelectMatches TeamId
tId
Zipper ChannelListGroup ChannelListEntry
zipper <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState (Zipper ChannelListGroup ChannelListEntry)
tsFocus)
let isCurrentFocus :: ChannelSelectMatch -> Bool
isCurrentFocus ChannelSelectMatch
m = forall a. a -> Maybe a
Just (ChannelSelectMatch -> ChannelListEntry
matchEntry ChannelSelectMatch
m) forall a. Eq a => a -> a -> Bool
== forall a b. Zipper a b -> Maybe b
Z.focus Zipper ChannelListGroup ChannelListEntry
zipper
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState ChannelSelectState
tsChannelSelectStateforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens'
ChannelSelectState (Zipper ChannelListGroup ChannelSelectMatch)
channelSelectMatches forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall b a. (b -> Bool) -> Zipper a b -> Zipper a b
Z.findRight ChannelSelectMatch -> Bool
isCurrentFocus
channelSelectNext :: MM.TeamId -> MH ()
channelSelectNext :: TeamId -> MH ()
channelSelectNext TeamId
tId = TeamId
-> (Zipper ChannelListGroup ChannelSelectMatch
-> Zipper ChannelListGroup ChannelSelectMatch)
-> MH ()
updateSelectedMatch TeamId
tId forall a b. Zipper a b -> Zipper a b
Z.right
channelSelectPrevious :: MM.TeamId -> MH ()
channelSelectPrevious :: TeamId -> MH ()
channelSelectPrevious TeamId
tId = TeamId
-> (Zipper ChannelListGroup ChannelSelectMatch
-> Zipper ChannelListGroup ChannelSelectMatch)
-> MH ()
updateSelectedMatch TeamId
tId forall a b. Zipper a b -> Zipper a b
Z.left
updateChannelSelectMatches :: MM.TeamId -> MH ()
updateChannelSelectMatches :: TeamId -> MH ()
updateChannelSelectMatches TeamId
tId = do
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
Editor Text Name
input <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState ChannelSelectState
tsChannelSelectStateforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelSelectState (Editor Text Name)
channelSelectInput)
Maybe ClientConfig
cconfig <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' ChatState (Maybe ClientConfig)
csClientConfig
UserPreferences
prefs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources UserPreferences
crUserPreferences)
let pat :: Maybe ChannelSelectPattern
pat = Text -> Maybe ChannelSelectPattern
parseChannelSelectPattern forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall t n. Monoid t => Editor t n -> [t]
getEditContents Editor Text Name
input
chanNameMatches :: ChannelListEntry -> Text -> Maybe ChannelSelectMatch
chanNameMatches ChannelListEntry
e = case Maybe ChannelSelectPattern
pat of
Maybe ChannelSelectPattern
Nothing -> forall a b. a -> b -> a
const forall a. Maybe a
Nothing
Just ChannelSelectPattern
p -> ChannelSelectPattern
-> ChannelListEntry -> Text -> Maybe ChannelSelectMatch
applySelectPattern ChannelSelectPattern
p ChannelListEntry
e
patTy :: Maybe MatchType
patTy = case Maybe ChannelSelectPattern
pat of
Maybe ChannelSelectPattern
Nothing -> forall a. Maybe a
Nothing
Just ChannelSelectPattern
CSPAny -> forall a. Maybe a
Nothing
Just (CSP MatchType
ty Text
_) -> forall a. a -> Maybe a
Just MatchType
ty
let chanMatches :: ChannelListEntry -> ClientChannel -> Maybe ChannelSelectMatch
chanMatches ChannelListEntry
e ClientChannel
chan =
if Maybe MatchType
patTy forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just MatchType
PrefixDMOnly
then forall a. Maybe a
Nothing
else if ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Type
cdType forall a. Eq a => a -> a -> Bool
/= Type
MM.Group
then ChannelListEntry -> Text -> Maybe ChannelSelectMatch
chanNameMatches ChannelListEntry
e forall a b. (a -> b) -> a -> b
$ ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Text
cdDisplayName
else forall a. Maybe a
Nothing
groupChanMatches :: ChannelListEntry -> ClientChannel -> Maybe ChannelSelectMatch
groupChanMatches ChannelListEntry
e ClientChannel
chan =
if Maybe MatchType
patTy forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just MatchType
PrefixNonDMOnly
then forall a. Maybe a
Nothing
else if ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Type
cdType forall a. Eq a => a -> a -> Bool
== Type
MM.Group
then ChannelListEntry -> Text -> Maybe ChannelSelectMatch
chanNameMatches ChannelListEntry
e forall a b. (a -> b) -> a -> b
$ ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Text
cdDisplayName
else forall a. Maybe a
Nothing
displayName :: UserInfo -> Text
displayName UserInfo
uInfo = UserInfo -> Maybe ClientConfig -> UserPreferences -> Text
displayNameForUser UserInfo
uInfo Maybe ClientConfig
cconfig UserPreferences
prefs
userMatches :: ChannelListEntry -> UserInfo -> Maybe ChannelSelectMatch
userMatches ChannelListEntry
e UserInfo
uInfo =
if Maybe MatchType
patTy forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just MatchType
PrefixNonDMOnly
then forall a. Maybe a
Nothing
else (ChannelListEntry -> Text -> Maybe ChannelSelectMatch
chanNameMatches ChannelListEntry
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserInfo -> Text
displayName) UserInfo
uInfo
matches :: ChannelListEntry -> Maybe ChannelSelectMatch
matches ChannelListEntry
e =
let cId :: ChannelId
cId = ChannelListEntry -> ChannelId
channelListEntryChannelId ChannelListEntry
e
in case ChannelListEntry -> ChannelListEntryType
channelListEntryType ChannelListEntry
e of
ChannelListEntryType
CLChannel -> ChannelId -> ClientChannels -> Maybe ClientChannel
findChannelById ChannelId
cId (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ClientChannels
csChannels) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChannelListEntry -> ClientChannel -> Maybe ChannelSelectMatch
chanMatches ChannelListEntry
e
CLUserDM UserId
uId -> UserId -> ChatState -> Maybe UserInfo
userById UserId
uId ChatState
st forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChannelListEntry -> UserInfo -> Maybe ChannelSelectMatch
userMatches ChannelListEntry
e
ChannelListEntryType
CLGroupDM -> ChannelId -> ClientChannels -> Maybe ClientChannel
findChannelById ChannelId
cId (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ClientChannels
csChannels) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChannelListEntry -> ClientChannel -> Maybe ChannelSelectMatch
groupChanMatches ChannelListEntry
e
preserveFocus :: Maybe ChannelSelectMatch -> ChannelSelectMatch -> Bool
preserveFocus Maybe ChannelSelectMatch
Nothing ChannelSelectMatch
_ = Bool
False
preserveFocus (Just ChannelSelectMatch
m) ChannelSelectMatch
m2 = ChannelSelectMatch -> ChannelListEntry
matchEntry ChannelSelectMatch
m forall a. Eq a => a -> a -> Bool
== ChannelSelectMatch -> ChannelListEntry
matchEntry ChannelSelectMatch
m2
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState ChannelSelectState
tsChannelSelectStateforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens'
ChannelSelectState (Zipper ChannelListGroup ChannelSelectMatch)
channelSelectMatches forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%=
(forall b a.
Eq b =>
(Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b
Z.updateListBy Maybe ChannelSelectMatch -> ChannelSelectMatch -> Bool
preserveFocus forall a b. (a -> b) -> a -> b
$ forall a b. Zipper a b -> [(a, [b])]
Z.toList forall a b. (a -> b) -> a -> b
$ forall c b a. Eq c => (b -> Maybe c) -> Zipper a b -> Zipper a c
Z.maybeMapZipper ChannelListEntry -> Maybe ChannelSelectMatch
matches (ChatState
stforall s a. s -> Getting a s a -> a
^.TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState (Zipper ChannelListGroup ChannelListEntry)
tsFocus))
applySelectPattern :: ChannelSelectPattern -> ChannelListEntry -> Text -> Maybe ChannelSelectMatch
applySelectPattern :: ChannelSelectPattern
-> ChannelListEntry -> Text -> Maybe ChannelSelectMatch
applySelectPattern ChannelSelectPattern
CSPAny ChannelListEntry
entry Text
chanName = do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
-> Text -> Text -> Text -> ChannelListEntry -> ChannelSelectMatch
ChannelSelectMatch Text
"" Text
"" Text
chanName Text
chanName ChannelListEntry
entry
applySelectPattern (CSP MatchType
ty Text
pat) ChannelListEntry
entry Text
chanName = do
let applyType :: MatchType -> Maybe (Text, Text, Text)
applyType MatchType
Infix | Text
pat Text -> Text -> Bool
`T.isInfixOf` Text
normalizedChanName =
case Text -> Text -> (Text, Text)
T.breakOn Text
pat Text
normalizedChanName of
(Text
pre, Text
_) ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( Int -> Text -> Text
T.take (Text -> Int
T.length Text
pre) Text
chanName
, Int -> Text -> Text
T.take (Text -> Int
T.length Text
pat) forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
pre) Text
chanName
, Int -> Text -> Text
T.drop (Text -> Int
T.length Text
pat forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
pre) Text
chanName
)
applyType MatchType
Prefix | Text
pat Text -> Text -> Bool
`T.isPrefixOf` Text
normalizedChanName = do
let (Text
b, Text
a) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
pat) Text
chanName
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"", Text
b, Text
a)
applyType MatchType
PrefixDMOnly | Text
pat Text -> Text -> Bool
`T.isPrefixOf` Text
normalizedChanName = do
let (Text
b, Text
a) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
pat) Text
chanName
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"", Text
b, Text
a)
applyType MatchType
PrefixNonDMOnly | Text
pat Text -> Text -> Bool
`T.isPrefixOf` Text
normalizedChanName = do
let (Text
b, Text
a) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
pat) Text
chanName
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"", Text
b, Text
a)
applyType MatchType
Suffix | Text
pat Text -> Text -> Bool
`T.isSuffixOf` Text
normalizedChanName = do
let (Text
b, Text
a) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
chanName forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
pat) Text
chanName
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
b, Text
a, Text
"")
applyType MatchType
Equal | Text
pat forall a. Eq a => a -> a -> Bool
== Text
normalizedChanName =
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"", Text
chanName, Text
"")
applyType MatchType
_ = forall a. Maybe a
Nothing
caseSensitive :: Bool
caseSensitive = (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isUpper Text
pat
normalizedChanName :: Text
normalizedChanName = if Bool
caseSensitive
then Text
chanName
else Text -> Text
T.toLower Text
chanName
(Text
pre, Text
m, Text
post) <- MatchType -> Maybe (Text, Text, Text)
applyType MatchType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
-> Text -> Text -> Text -> ChannelListEntry -> ChannelSelectMatch
ChannelSelectMatch Text
pre Text
m Text
post Text
chanName ChannelListEntry
entry
parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern
parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern
parseChannelSelectPattern Text
"" = forall (m :: * -> *) a. Monad m => a -> m a
return ChannelSelectPattern
CSPAny
parseChannelSelectPattern Text
pat = do
let only :: Maybe ChannelSelectPattern
only = if | Text
userSigil Text -> Text -> Bool
`T.isPrefixOf` Text
pat -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ MatchType -> Text -> ChannelSelectPattern
CSP MatchType
PrefixDMOnly forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
pat
| Text
normalChannelSigil Text -> Text -> Bool
`T.isPrefixOf` Text
pat -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ MatchType -> Text -> ChannelSelectPattern
CSP MatchType
PrefixNonDMOnly forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
pat
| Bool
otherwise -> forall a. Maybe a
Nothing
(Text
pat1, Maybe MatchType
pfx) <- case Text
"^" Text -> Text -> Bool
`T.isPrefixOf` Text
pat of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
T.tail Text
pat, forall a. a -> Maybe a
Just MatchType
Prefix)
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text
pat, forall a. Maybe a
Nothing)
(Text
pat2, Maybe MatchType
sfx) <- case Text
"$" Text -> Text -> Bool
`T.isSuffixOf` Text
pat1 of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
T.init Text
pat1, forall a. a -> Maybe a
Just MatchType
Suffix)
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text
pat1, forall a. Maybe a
Nothing)
Maybe ChannelSelectPattern
only forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case (Maybe MatchType
pfx, Maybe MatchType
sfx) of
(Maybe MatchType
Nothing, Maybe MatchType
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MatchType -> Text -> ChannelSelectPattern
CSP MatchType
Infix Text
pat2
(Just MatchType
Prefix, Maybe MatchType
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MatchType -> Text -> ChannelSelectPattern
CSP MatchType
Prefix Text
pat2
(Maybe MatchType
Nothing, Just MatchType
Suffix) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MatchType -> Text -> ChannelSelectPattern
CSP MatchType
Suffix Text
pat2
(Just MatchType
Prefix, Just MatchType
Suffix) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MatchType -> Text -> ChannelSelectPattern
CSP MatchType
Equal Text
pat2
(Maybe MatchType, Maybe MatchType)
tys -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"BUG: invalid channel select case: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Maybe MatchType, Maybe MatchType)
tys
updateSelectedMatch :: MM.TeamId
-> (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch)
-> MH ()
updateSelectedMatch :: TeamId
-> (Zipper ChannelListGroup ChannelSelectMatch
-> Zipper ChannelListGroup ChannelSelectMatch)
-> MH ()
updateSelectedMatch TeamId
tId Zipper ChannelListGroup ChannelSelectMatch
-> Zipper ChannelListGroup ChannelSelectMatch
nextItem =
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState ChannelSelectState
tsChannelSelectStateforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens'
ChannelSelectState (Zipper ChannelListGroup ChannelSelectMatch)
channelSelectMatches forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Zipper ChannelListGroup ChannelSelectMatch
-> Zipper ChannelListGroup ChannelSelectMatch
nextItem