1{-# LANGUAGE MultiWayIf #-} 2module Matterhorn.State.ChannelSelect 3 ( beginChannelSelect 4 , updateChannelSelectMatches 5 , channelSelectNext 6 , channelSelectPrevious 7 ) 8where 9 10import Prelude () 11import Matterhorn.Prelude 12 13import Brick.Widgets.Edit ( getEditContents ) 14import Data.Char ( isUpper ) 15import qualified Data.Text as T 16import Lens.Micro.Platform 17 18import qualified Network.Mattermost.Types as MM 19 20import Matterhorn.Constants ( userSigil, normalChannelSigil ) 21import Matterhorn.Types 22import qualified Matterhorn.Zipper as Z 23 24beginChannelSelect :: MH () 25beginChannelSelect = do 26 setMode ChannelSelect 27 tId <- use csCurrentTeamId 28 csCurrentTeam.tsChannelSelectState .= emptyChannelSelectState tId 29 updateChannelSelectMatches 30 31 -- Preserve the current channel selection when initializing channel 32 -- selection mode 33 zipper <- use (csCurrentTeam.tsFocus) 34 let isCurrentFocus m = Just (matchEntry m) == Z.focus zipper 35 csCurrentTeam.tsChannelSelectState.channelSelectMatches %= Z.findRight isCurrentFocus 36 37-- Select the next match in channel selection mode. 38channelSelectNext :: MH () 39channelSelectNext = updateSelectedMatch Z.right 40 41-- Select the previous match in channel selection mode. 42channelSelectPrevious :: MH () 43channelSelectPrevious = updateSelectedMatch Z.left 44 45updateChannelSelectMatches :: MH () 46updateChannelSelectMatches = do 47 st <- use id 48 49 input <- use (csCurrentTeam.tsChannelSelectState.channelSelectInput) 50 cconfig <- use csClientConfig 51 prefs <- use (csResources.crUserPreferences) 52 53 let pat = parseChannelSelectPattern $ T.concat $ getEditContents input 54 chanNameMatches e = case pat of 55 Nothing -> const Nothing 56 Just p -> applySelectPattern p e 57 patTy = case pat of 58 Nothing -> Nothing 59 Just CSPAny -> Nothing 60 Just (CSP ty _) -> Just ty 61 62 let chanMatches e chan = 63 if patTy == Just PrefixDMOnly 64 then Nothing 65 else if chan^.ccInfo.cdType /= MM.Group 66 then chanNameMatches e $ chan^.ccInfo.cdDisplayName 67 else Nothing 68 groupChanMatches e chan = 69 if patTy == Just PrefixNonDMOnly 70 then Nothing 71 else if chan^.ccInfo.cdType == MM.Group 72 then chanNameMatches e $ chan^.ccInfo.cdDisplayName 73 else Nothing 74 displayName uInfo = displayNameForUser uInfo cconfig prefs 75 userMatches e uInfo = 76 if patTy == Just PrefixNonDMOnly 77 then Nothing 78 else (chanNameMatches e . displayName) uInfo 79 matches e = 80 let cId = channelListEntryChannelId e 81 in case channelListEntryType e of 82 CLChannel -> findChannelById cId (st^.csChannels) >>= chanMatches e 83 CLUserDM uId -> userById uId st >>= userMatches e 84 CLGroupDM -> findChannelById cId (st^.csChannels) >>= groupChanMatches e 85 86 preserveFocus Nothing _ = False 87 preserveFocus (Just m) m2 = matchEntry m == matchEntry m2 88 89 csCurrentTeam.tsChannelSelectState.channelSelectMatches %= 90 (Z.updateListBy preserveFocus $ Z.toList $ Z.maybeMapZipper matches (st^.csCurrentTeam.tsFocus)) 91 92applySelectPattern :: ChannelSelectPattern -> ChannelListEntry -> Text -> Maybe ChannelSelectMatch 93applySelectPattern CSPAny entry chanName = do 94 return $ ChannelSelectMatch "" "" chanName chanName entry 95applySelectPattern (CSP ty pat) entry chanName = do 96 let applyType Infix | pat `T.isInfixOf` normalizedChanName = 97 case T.breakOn pat normalizedChanName of 98 (pre, _) -> 99 return ( T.take (T.length pre) chanName 100 , T.take (T.length pat) $ T.drop (T.length pre) chanName 101 , T.drop (T.length pat + T.length pre) chanName 102 ) 103 104 applyType Prefix | pat `T.isPrefixOf` normalizedChanName = do 105 let (b, a) = T.splitAt (T.length pat) chanName 106 return ("", b, a) 107 108 applyType PrefixDMOnly | pat `T.isPrefixOf` normalizedChanName = do 109 let (b, a) = T.splitAt (T.length pat) chanName 110 return ("", b, a) 111 112 applyType PrefixNonDMOnly | pat `T.isPrefixOf` normalizedChanName = do 113 let (b, a) = T.splitAt (T.length pat) chanName 114 return ("", b, a) 115 116 applyType Suffix | pat `T.isSuffixOf` normalizedChanName = do 117 let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName 118 return (b, a, "") 119 120 applyType Equal | pat == normalizedChanName = 121 return ("", chanName, "") 122 123 applyType _ = Nothing 124 125 caseSensitive = T.any isUpper pat 126 normalizedChanName = if caseSensitive 127 then chanName 128 else T.toLower chanName 129 130 (pre, m, post) <- applyType ty 131 return $ ChannelSelectMatch pre m post chanName entry 132 133parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern 134parseChannelSelectPattern "" = return CSPAny 135parseChannelSelectPattern pat = do 136 let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP PrefixDMOnly $ T.tail pat 137 | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP PrefixNonDMOnly $ T.tail pat 138 | otherwise -> Nothing 139 140 (pat1, pfx) <- case "^" `T.isPrefixOf` pat of 141 True -> return (T.tail pat, Just Prefix) 142 False -> return (pat, Nothing) 143 144 (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of 145 True -> return (T.init pat1, Just Suffix) 146 False -> return (pat1, Nothing) 147 148 only <|> case (pfx, sfx) of 149 (Nothing, Nothing) -> return $ CSP Infix pat2 150 (Just Prefix, Nothing) -> return $ CSP Prefix pat2 151 (Nothing, Just Suffix) -> return $ CSP Suffix pat2 152 (Just Prefix, Just Suffix) -> return $ CSP Equal pat2 153 tys -> error $ "BUG: invalid channel select case: " <> show tys 154 155-- Update the channel selection mode match cursor. The argument function 156-- determines how to navigate to the next item. 157updateSelectedMatch :: (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch) 158 -> MH () 159updateSelectedMatch nextItem = 160 csCurrentTeam.tsChannelSelectState.channelSelectMatches %= nextItem 161