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