Enforce max completions over all plugins (#1256)

* Enforce max completions across HLS plugins

* Fix pragma completions to prefilter

* Fix a completion test

* Add a test

* Fix another inaccurate test

* rename n to limit

* Evaluate completion providers in parallel

* Evaluate all HLS providers concurrently

Author: pepeiborra

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -30,7 +30,7 @@ import Development.IDE.GHC.Util
 import Development.IDE.LSP.Server
 import TcRnDriver (tcRnImportDecls)
 import Data.Maybe
-import Ide.Plugin.Config (Config (completionSnippetsOn, maxCompletions))
+import Ide.Plugin.Config (Config (completionSnippetsOn))
 import Ide.PluginUtils (getClientConfig)
 
 #if defined(GHC_LIB)
@@ -146,8 +146,7 @@ getCompletionsLSP lsp ide
                 config <- getClientConfig lsp
                 let snippets = WithSnippets . completionSnippetsOn $ config
                 allCompletions <- getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps snippets
-                let (topCompletions, rest) = splitAt (maxCompletions config) allCompletions
-                pure $ CompletionList (CompletionListType (null rest) (List topCompletions))
+                pure $ Completions (List allCompletions)
               _ -> return (Completions $ List [])
           _ -> return (Completions $ List [])
       _ -> return (Completions $ List [])

ghcide/src/Development/IDE/Plugin/HLS.hs

@@ -6,9 +6,10 @@ module Development.IDE.Plugin.HLS
     ) where
 
 import           Control.Exception(SomeException, catch)
-import           Control.Lens ( (^.) )
+import           Control.Lens ((^.))
 import           Control.Monad
 import qualified Data.Aeson as J
+import qualified Data.DList as DList
 import           Data.Either
 import qualified Data.List                     as List
 import qualified Data.Map  as Map
@@ -33,6 +34,7 @@ import Development.Shake (Rules)
 import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)
 import Development.IDE.Types.Logger (logInfo)
 import Development.IDE.Core.Tracing
+import Control.Concurrent.Async (mapConcurrently)
 
 -- ---------------------------------------------------------------------
 
@@ -97,7 +99,7 @@ makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do
           if pluginEnabled pluginConfig plcCodeActionsOn
             then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context
             else return $ Right (List [])
-    r <- mapM makeAction cas
+    r <- mapConcurrently makeAction cas
     let actions = filter wasRequested . foldMap unL $ rights r
     res <- send caps actions
     return $ Right res
@@ -171,7 +173,7 @@ makeCodeLens cas lf ideState params = do
           doOneRight (pid, Right a) = [(pid,a)]
           doOneRight (_, Left _) = []
 
-    r <- mapM makeLens cas
+    r <- mapConcurrently makeLens cas
     case breakdown r of
         ([],[]) -> return $ Right $ List []
         (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing
@@ -306,7 +308,7 @@ makeHover hps lf ideState params
           if pluginEnabled pluginConfig plcHoverOn
              then otTracedProvider pid "hover" $ p ideState params
              else return $ Right Nothing
-      mhs <- mapM makeHover hps
+      mhs <- mapConcurrently makeHover hps
       -- TODO: We should support ServerCapabilities and declare that
       -- we don't support hover requests during initialization if we
       -- don't have any hover providers
@@ -361,7 +363,7 @@ makeSymbols sps lf ideState params
             if pluginEnabled pluginConfig plcSymbolsOn
               then otTracedProvider pid "symbols" $ p lf ideState params
               else return $ Right []
-      mhs <- mapM makeSymbols sps
+      mhs <- mapConcurrently makeSymbols sps
       case rights mhs of
           [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs
           hs -> return $ Right $ convertSymbols $ concat hs
@@ -391,7 +393,7 @@ renameWith providers lspFuncs state params = do
              then otTracedProvider pid "rename" $ p lspFuncs state params
              else return $ Right $ WorkspaceEdit Nothing Nothing
     -- TODO:AZ: we need to consider the right way to combine possible renamers
-    results <- mapM makeAction providers
+    results <- mapConcurrently makeAction providers
     case partitionEithers results of
         (errors, []) -> return $ Left $ responseError $ T.pack $ show errors
         (_, edits) -> return $ Right $ mconcat edits
@@ -436,22 +438,23 @@ makeCompletions :: [(PluginId, CompletionProvider IdeState)]
 makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt)
   = do
       mprefix <- getPrefixAtPos lf doc pos
-      _snippets <- WithSnippets . completionSnippetsOn <$> getClientConfig lf
+      maxCompletions <- maxCompletions <$> getClientConfig lf
 
       let
           combine :: [CompletionResponseResult] -> CompletionResponseResult
-          combine cs = go (Completions $ List []) cs
-              where
-                  go acc [] = acc
-                  go (Completions (List ls)) (Completions (List ls2):rest)
-                      = go (Completions (List (ls <> ls2))) rest
-                  go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest)
-                      = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest
-                  go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest)
-                      = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest
-                  go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest)
-                      = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest
-          makeAction (pid,p) = do
+          combine cs = go True mempty cs
+
+          go !comp acc [] =
+            CompletionList (CompletionListType comp (List $ DList.toList acc))
+          go comp acc (Completions (List ls) : rest) =
+            go comp (acc <> DList.fromList ls) rest
+          go comp acc (CompletionList (CompletionListType comp' (List ls)) : rest) =
+            go (comp && comp') (acc <> DList.fromList ls) rest
+
+          makeAction ::
+            (PluginId, CompletionProvider IdeState) ->
+            IO (Either ResponseError CompletionResponseResult)
+          makeAction (pid, p) = do
             pluginConfig <- getPluginConfig lf pid
             if pluginEnabled pluginConfig plcCompletionOn
                then otTracedProvider pid "completions" $ p lf ideState params
@@ -460,10 +463,19 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier
       case mprefix of
           Nothing -> return $ Right $ Completions $ List []
           Just _prefix -> do
-            mhs <- mapM makeAction sps
+            mhs <- mapConcurrently makeAction sps
             case rights mhs of
                 [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs
-                hs -> return $ Right $ combine hs
+                hs -> return $ Right $ snd $ consumeCompletionResponse maxCompletions $ combine hs
+
+-- | Crops a completion response. Returns the final number of completions and the cropped response
+consumeCompletionResponse :: Int -> CompletionResponseResult -> (Int, CompletionResponseResult)
+consumeCompletionResponse limit it@(CompletionList (CompletionListType _ (List xx))) =
+  case splitAt limit xx of
+    (_, []) -> (limit - length xx, it)
+    (xx', _) -> (0, CompletionList (CompletionListType False (List xx')))
+consumeCompletionResponse n (Completions (List xx)) =
+  consumeCompletionResponse n (CompletionList (CompletionListType False (List xx)))
 
 getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo)
 getPrefixAtPos lf uri pos = do

haskell-language-server.cabal

@@ -220,6 +220,7 @@ common moduleName
 common pragmas
   if flag(pragmas) || flag(all-plugins)
     hs-source-dirs: plugins/default/src
+    build-depends: fuzzy
     other-modules: Ide.Plugin.Pragmas
     cpp-options: -Dpragmas
 

plugins/default/src/Ide/Plugin/Pragmas.hs

@@ -8,7 +8,6 @@
 module Ide.Plugin.Pragmas
   (
       descriptor
-  -- ,   commands -- TODO: get rid of this
   ) where
 
 import           Control.Lens                    hiding (List)
@@ -25,7 +24,8 @@ import qualified Language.Haskell.LSP.Types.Lens as J
 import           Control.Monad                   (join)
 import           Development.IDE.GHC.Compat
 import qualified Language.Haskell.LSP.Core       as LSP
-import qualified Language.Haskell.LSP.VFS        as VFS
+import qualified Language.Haskell.LSP.VFS as VFS
+import qualified Text.Fuzzy as Fuzzy
 
 -- ---------------------------------------------------------------------
 
@@ -142,13 +142,13 @@ completion lspFuncs _ide complParams = do
         position = complParams ^. J.position
     contents <- LSP.getVirtualFileFunc lspFuncs $ toNormalizedUri uri
     fmap Right $ case (contents, uriToFilePath' uri) of
-        (Just cnts, Just _path) -> do
-            pfix <- VFS.getCompletionPrefix position cnts
-            return $ result pfix
+        (Just cnts, Just _path) ->
+            result <$> VFS.getCompletionPrefix position cnts
             where
                 result (Just pfix)
                     | "{-# LANGUAGE" `T.isPrefixOf` VFS.fullLine pfix
-                    = Completions $ List $ map buildCompletion allPragmas
+                    = Completions $ List $ map buildCompletion
+                        (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
                     | otherwise
                     = Completions $ List []
                 result Nothing = Completions $ List []

test/functional/Completion.hs

@@ -13,6 +13,8 @@ import Test.Tasty
 import Test.Tasty.ExpectedFailure (ignoreTestBecause)
 import Test.Tasty.HUnit
 import qualified Data.Text as T
+import Data.Default (def)
+import Ide.Plugin.Config (Config (maxCompletions))
 
 tests :: TestTree
 tests = testGroup "completions" [
@@ -102,7 +104,7 @@ tests = testGroup "completions" [
          let te = TextEdit (Range (Position 0 13) (Position 0 31)) "Str"
          _ <- applyEdit doc te
 
-         compls <- getCompletions doc (Position 0 24)
+         compls <- getCompletions doc (Position 0 16)
          let item = head $ filter ((== "Strict") . (^. label)) compls
          liftIO $ do
              item ^. label @?= "Strict"
@@ -116,7 +118,7 @@ tests = testGroup "completions" [
          let te = TextEdit (Range (Position 0 13) (Position 0 31)) "NoOverload"
          _ <- applyEdit doc te
 
-         compls <- getCompletions doc (Position 0 24)
+         compls <- getCompletions doc (Position 0 23)
          let item = head $ filter ((== "NoOverloadedStrings") . (^. label)) compls
          liftIO $ do
              item ^. label @?= "NoOverloadedStrings"
@@ -221,6 +223,12 @@ tests = testGroup "completions" [
          liftIO $
              item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c"
 
+     , testCase "maxCompletions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
+         doc <- openDoc "Completion.hs" "haskell"
+
+         compls <- getCompletions doc (Position 5 7)
+         liftIO $ length compls @?= maxCompletions def
+
      , contextTests
      , snippetTests
     ]