1module Matterhorn.State.Autocomplete 2 ( AutocompleteContext(..) 3 , checkForAutocompletion 4 ) 5where 6 7import Prelude () 8import Matterhorn.Prelude 9 10import Brick.Main ( viewportScroll, vScrollToBeginning ) 11import Brick.Widgets.Edit ( editContentsL ) 12import qualified Brick.Widgets.List as L 13import Data.Char ( isSpace ) 14import qualified Data.Foldable as F 15import qualified Data.HashMap.Strict as HM 16import Data.List ( sortBy, partition ) 17import qualified Data.Map as M 18import qualified Data.Sequence as Seq 19import qualified Data.Text as T 20import qualified Data.Text.Zipper as Z 21import qualified Data.Vector as V 22import Lens.Micro.Platform ( (%=), (.=), (.~), _Just, preuse ) 23import qualified Skylighting.Types as Sky 24 25import Network.Mattermost.Types (userId, channelId, Command(..), TeamId) 26import qualified Network.Mattermost.Endpoints as MM 27 28import Matterhorn.Constants ( userSigil, normalChannelSigil ) 29import {-# SOURCE #-} Matterhorn.Command ( commandList, printArgSpec ) 30import Matterhorn.State.Common 31import {-# SOURCE #-} Matterhorn.State.Editing ( Direction(..), tabComplete ) 32import Matterhorn.Types hiding ( newState ) 33import Matterhorn.Emoji 34 35 36data AutocompleteContext = 37 AutocompleteContext { autocompleteManual :: Bool 38 -- ^ Whether the autocompletion was manual 39 -- (True) or automatic (False). The automatic 40 -- case is the case where the autocomplete 41 -- lookups and UI are triggered merely by 42 -- entering some initial text (such as "@"). 43 -- The manual case is the case where the 44 -- autocomplete lookups and UI are triggered 45 -- explicitly by a user's TAB keypress. 46 , autocompleteFirstMatch :: Bool 47 -- ^ Once the results of the autocomplete lookup 48 -- are available, this flag determines whether 49 -- the user's input is replaced immediately 50 -- with the first available match (True) or not 51 -- (False). 52 } 53 54-- | Check for whether the currently-edited word in the message editor 55-- should cause an autocompletion UI to appear. If so, initiate a server 56-- query or local cache lookup to present the completion alternatives 57-- for the word at the cursor. 58checkForAutocompletion :: AutocompleteContext -> MH () 59checkForAutocompletion ctx = do 60 result <- getCompleterForInput ctx 61 case result of 62 Nothing -> resetAutocomplete 63 Just (ty, runUpdater, searchString) -> do 64 prevResult <- use (csCurrentTeam.tsEditState.cedAutocomplete) 65 -- We should update the completion state if EITHER: 66 -- 67 -- 1) The type changed 68 -- 69 -- or 70 -- 71 -- 2) The search string changed but the type did NOT change 72 let shouldUpdate = ((maybe True ((/= searchString) . _acPreviousSearchString) 73 prevResult) && 74 (maybe True ((== ty) . _acType) prevResult)) || 75 (maybe False ((/= ty) . _acType) prevResult) 76 when shouldUpdate $ do 77 csCurrentTeam.tsEditState.cedAutocompletePending .= Just searchString 78 runUpdater ty ctx searchString 79 80getCompleterForInput :: AutocompleteContext 81 -> MH (Maybe (AutocompletionType, AutocompletionType -> AutocompleteContext -> Text -> MH (), Text)) 82getCompleterForInput ctx = do 83 z <- use (csCurrentTeam.tsEditState.cedEditor.editContentsL) 84 85 let col = snd $ Z.cursorPosition z 86 curLine = Z.currentLine z 87 88 return $ case wordAtColumn col curLine of 89 Just (startCol, w) 90 | userSigil `T.isPrefixOf` w -> 91 Just (ACUsers, doUserAutoCompletion, T.tail w) 92 | normalChannelSigil `T.isPrefixOf` w -> 93 Just (ACChannels, doChannelAutoCompletion, T.tail w) 94 | ":" `T.isPrefixOf` w && autocompleteManual ctx -> 95 Just (ACEmoji, doEmojiAutoCompletion, T.tail w) 96 | "```" `T.isPrefixOf` w -> 97 Just (ACCodeBlockLanguage, doSyntaxAutoCompletion, T.drop 3 w) 98 | "/" `T.isPrefixOf` w && startCol == 0 -> 99 Just (ACCommands, doCommandAutoCompletion, T.tail w) 100 _ -> Nothing 101 102-- Completion implementations 103 104doEmojiAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () 105doEmojiAutoCompletion ty ctx searchString = do 106 session <- getSession 107 em <- use (csResources.crEmoji) 108 tId <- use csCurrentTeamId 109 withCachedAutocompleteResults tId ctx ty searchString $ 110 doAsyncWith Preempt $ do 111 results <- getMatchingEmoji session em searchString 112 let alts = EmojiCompletion <$> results 113 return $ Just $ setCompletionAlternatives tId ctx searchString alts ty 114 115doSyntaxAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () 116doSyntaxAutoCompletion ty ctx searchString = do 117 mapping <- use (csResources.crSyntaxMap) 118 tId <- use csCurrentTeamId 119 let allNames = Sky.sShortname <$> M.elems mapping 120 (prefixed, notPrefixed) = partition isPrefixed $ filter match allNames 121 match = (((T.toLower searchString) `T.isInfixOf`) . T.toLower) 122 isPrefixed = (((T.toLower searchString) `T.isPrefixOf`) . T.toLower) 123 alts = SyntaxCompletion <$> (sort prefixed <> sort notPrefixed) 124 setCompletionAlternatives tId ctx searchString alts ty 125 126-- | This list of server commands should be hidden because they make 127-- assumptions about a web-based client or otherwise just don't make 128-- sense for Matterhorn. 129-- 130-- It's worth mentioning that other official mattermost client 131-- implementations use this technique, too. The web client maintains 132-- a list of commands to exclude when they aren't supported in the 133-- mobile client. (Really this is a design flaw; they should never be 134-- advertised by the server to begin with.) 135hiddenServerCommands :: [Text] 136hiddenServerCommands = 137 -- These commands all only work in the web client. 138 [ "settings" 139 , "help" 140 , "collapse" 141 , "expand" 142 143 -- We don't think this command makes sense for Matterhorn. 144 , "logout" 145 146 , "remove" 147 , "msg" 148 149 -- We provide a version of /leave with confirmation. 150 , "leave" 151 152 -- We provide our own join UI. 153 , "join" 154 155 -- We provide our own search UI. 156 , "search" 157 158 -- We provide our own version of this command that opens our own 159 -- help UI. 160 , "shortcuts" 161 162 -- Hidden because we provide other mechanisms to switch between 163 -- channels. 164 , "open" 165 ] 166 167hiddenCommand :: Command -> Bool 168hiddenCommand c = (T.toLower $ commandTrigger c) `elem` hiddenServerCommands 169 170isDeletedCommand :: Command -> Bool 171isDeletedCommand cmd = commandDeleteAt cmd > commandCreateAt cmd 172 173doCommandAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () 174doCommandAutoCompletion ty ctx searchString = do 175 session <- getSession 176 myTid <- use csCurrentTeamId 177 178 mCache <- preuse (csTeam(myTid).tsEditState.cedAutocomplete._Just.acCachedResponses) 179 mActiveTy <- preuse (csTeam(myTid).tsEditState.cedAutocomplete._Just.acType) 180 181 -- Command completion works a little differently than the other 182 -- modes. To do command autocompletion, we want to query the server 183 -- for the list of available commands and merge that list with 184 -- our own list of client-provided commands. But the server's API 185 -- doesn't support *searching* commands; we can only ask for the 186 -- full list. That means that, unlike the other completion modes 187 -- where we want to ask the server repeatedly as the search string 188 -- is refined, in this case we want to ask the server only once 189 -- and avoid repeating the request for the same data as the user 190 -- types more of the search string. To accomplish that, we use a 191 -- special cache key -- the empty string, which normal user input 192 -- processing will never use -- as the cache key for the "full" list 193 -- of commands obtained by merging the server's list with our own. 194 -- We populate that cache entry when completion starts and then 195 -- subsequent completions consult *that* list instead of asking the 196 -- server again. Subsequent completions then filter and match the 197 -- cached list against the user's search string. 198 let entry = HM.lookup serverResponseKey =<< mCache 199 -- The special cache key to use to store the merged server and 200 -- client command list, sorted but otherwise unfiltered except 201 -- for eliminating deleted or hidden commands. 202 serverResponseKey = "" 203 lowerSearch = T.toLower searchString 204 matches (CommandCompletion _ name _ desc) = 205 lowerSearch `T.isInfixOf` (T.toLower name) || 206 lowerSearch `T.isInfixOf` (T.toLower desc) 207 matches _ = False 208 209 if (isNothing entry || (mActiveTy /= (Just ACCommands))) 210 then doAsyncWith Preempt $ do 211 let clientAlts = mkAlt <$> commandList 212 mkAlt (Cmd name desc args _) = 213 (Client, name, printArgSpec args, desc) 214 215 serverCommands <- MM.mmListCommandsForTeam myTid False session 216 let filteredServerCommands = 217 filter (\c -> not (hiddenCommand c || isDeletedCommand c)) $ 218 F.toList serverCommands 219 serverAlts = mkTuple <$> filteredServerCommands 220 mkTuple cmd = 221 ( Server 222 , commandTrigger cmd 223 , commandAutoCompleteHint cmd 224 , commandAutoCompleteDesc cmd 225 ) 226 mkCompletion (src, name, args, desc) = 227 CommandCompletion src name args desc 228 alts = fmap mkCompletion $ 229 clientAlts <> serverAlts 230 231 return $ Just $ do 232 -- Store the complete list of alterantives in the cache 233 setCompletionAlternatives myTid ctx serverResponseKey alts ty 234 235 -- Also store the list of alternatives specific to 236 -- this search string 237 let newAlts = sortBy (compareCommandAlts searchString) $ 238 filter matches alts 239 setCompletionAlternatives myTid ctx searchString newAlts ty 240 241 else case entry of 242 Just alts | mActiveTy == Just ACCommands -> 243 let newAlts = sortBy (compareCommandAlts searchString) $ 244 filter matches alts 245 in setCompletionAlternatives myTid ctx searchString newAlts ty 246 _ -> return () 247 248compareCommandAlts :: Text -> AutocompleteAlternative -> AutocompleteAlternative -> Ordering 249compareCommandAlts s (CommandCompletion _ nameA _ _) 250 (CommandCompletion _ nameB _ _) = 251 let isAPrefix = s `T.isPrefixOf` nameA 252 isBPrefix = s `T.isPrefixOf` nameB 253 in if isAPrefix == isBPrefix 254 then compare nameA nameB 255 else if isAPrefix 256 then LT 257 else GT 258compareCommandAlts _ _ _ = LT 259 260doUserAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () 261doUserAutoCompletion ty ctx searchString = do 262 session <- getSession 263 tId <- use csCurrentTeamId 264 myUid <- gets myUserId 265 cId <- use (csCurrentChannelId(tId)) 266 267 withCachedAutocompleteResults tId ctx ty searchString $ 268 doAsyncWith Preempt $ do 269 ac <- MM.mmAutocompleteUsers (Just tId) (Just cId) searchString session 270 271 let active = Seq.filter (\u -> userId u /= myUid && (not $ userDeleted u)) 272 alts = F.toList $ 273 ((\u -> UserCompletion u True) <$> (active $ MM.userAutocompleteUsers ac)) <> 274 (maybe mempty (fmap (\u -> UserCompletion u False) . active) $ 275 MM.userAutocompleteOutOfChannel ac) 276 277 specials = [ MentionAll 278 , MentionChannel 279 ] 280 extras = [ SpecialMention m | m <- specials 281 , (T.toLower searchString) `T.isPrefixOf` specialMentionName m 282 ] 283 284 return $ Just $ setCompletionAlternatives tId ctx searchString (alts <> extras) ty 285 286doChannelAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH () 287doChannelAutoCompletion ty ctx searchString = do 288 session <- getSession 289 tId <- use csCurrentTeamId 290 cs <- use csChannels 291 292 withCachedAutocompleteResults tId ctx ty searchString $ do 293 doAsyncWith Preempt $ do 294 results <- MM.mmAutocompleteChannels tId searchString session 295 let alts = F.toList $ (ChannelCompletion True <$> inChannels) <> 296 (ChannelCompletion False <$> notInChannels) 297 (inChannels, notInChannels) = Seq.partition isMember results 298 isMember c = isJust $ findChannelById (channelId c) cs 299 return $ Just $ setCompletionAlternatives tId ctx searchString alts ty 300 301-- Utility functions 302 303-- | Attempt to re-use a cached autocomplete alternative list for 304-- a given search string. If the cache contains no such entry (keyed 305-- on search string), run the specified action, which is assumed to be 306-- responsible for fetching the completion results from the server. 307withCachedAutocompleteResults :: TeamId 308 -> AutocompleteContext 309 -- ^ The autocomplete context 310 -> AutocompletionType 311 -- ^ The type of autocompletion we're 312 -- doing 313 -> Text 314 -- ^ The search string to look for in the 315 -- cache 316 -> MH () 317 -- ^ The action to execute on a cache miss 318 -> MH () 319withCachedAutocompleteResults tId ctx ty searchString act = do 320 mCache <- preuse (csTeam(tId).tsEditState.cedAutocomplete._Just.acCachedResponses) 321 mActiveTy <- preuse (csTeam(tId).tsEditState.cedAutocomplete._Just.acType) 322 323 case Just ty == mActiveTy of 324 True -> 325 -- Does the cache have results for this search string? If 326 -- so, use them; otherwise invoke the specified action. 327 case HM.lookup searchString =<< mCache of 328 Just alts -> setCompletionAlternatives tId ctx searchString alts ty 329 Nothing -> act 330 False -> act 331 332setCompletionAlternatives :: TeamId 333 -> AutocompleteContext 334 -> Text 335 -> [AutocompleteAlternative] 336 -> AutocompletionType 337 -> MH () 338setCompletionAlternatives tId ctx searchString alts ty = do 339 let list = L.list (CompletionList tId) (V.fromList $ F.toList alts) 1 340 state = AutocompleteState { _acPreviousSearchString = searchString 341 , _acCompletionList = 342 list & L.listSelectedL .~ Nothing 343 , _acCachedResponses = HM.fromList [(searchString, alts)] 344 , _acType = ty 345 } 346 347 pending <- use (csTeam(tId).tsEditState.cedAutocompletePending) 348 case pending of 349 Just val | val == searchString -> do 350 351 -- If there is already state, update it, but also cache the 352 -- search results. 353 csTeam(tId).tsEditState.cedAutocomplete %= \prev -> 354 let newState = case prev of 355 Nothing -> 356 state 357 Just oldState -> 358 state & acCachedResponses .~ 359 HM.insert searchString alts (oldState^.acCachedResponses) 360 in Just newState 361 362 mh $ vScrollToBeginning $ viewportScroll $ CompletionList tId 363 364 when (autocompleteFirstMatch ctx) $ 365 tabComplete Forwards 366 _ -> 367 -- Do not update the state if this result does not 368 -- correspond to the search string we used most recently. 369 -- This happens when the editor changes faster than the 370 -- async completion responses arrive from the server. If we 371 -- don't check this, we show completion results that are 372 -- wrong for the editor state. 373 return () 374 375wordAtColumn :: Int -> Text -> Maybe (Int, Text) 376wordAtColumn i t = 377 let tokens = T.groupBy (\a b -> isSpace a == isSpace b) t 378 go _ j _ | j < 0 = Nothing 379 go col j ts = case ts of 380 [] -> Nothing 381 (w:rest) | j <= T.length w && not (isSpace $ T.head w) -> Just (col, w) 382 | otherwise -> go (col + T.length w) (j - T.length w) rest 383 in go 0 i tokens 384