From 46c3e1f964d808c8d9afa8fd15da26a480215862 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 18 Jan 2021 20:55:30 +0000 Subject: [PATCH 1/8] Enforce max completions across HLS plugins --- .../src/Development/IDE/Plugin/Completions.hs | 5 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 53 +++++++++++++------ 2 files changed, 39 insertions(+), 19 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 70f5474b81..e0142f4c8e 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/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 []) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index c18619b36d..0527043ed1 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/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 @@ -436,35 +437,55 @@ 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 + config <- 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 + + -- | Process a list of completion providers until we reach a max number of results + makeAction :: + Int -> + [(PluginId, CompletionProvider IdeState)] -> + IO [Either ResponseError CompletionResponseResult] + makeAction 0 _ = return [] + makeAction _ [] = return [] + makeAction n ((pid, p) : rest) = do pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCompletionOn + results <- if pluginEnabled pluginConfig plcCompletionOn then otTracedProvider pid "completions" $ p lf ideState params else return $ Right $ Completions $ List [] + case results of + Right resp -> do + let (n', results') = consumeCompletionResponse n resp + (Right results' :) <$> makeAction n' rest + Left err -> + (Left err :) <$> makeAction n rest case mprefix of Nothing -> return $ Right $ Completions $ List [] Just _prefix -> do - mhs <- mapM makeAction sps + mhs <- makeAction (maxCompletions config) sps case rights mhs of [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs hs -> return $ Right $ combine hs +-- | Crops a completion response. Returns the final number of completions and the cropped response +consumeCompletionResponse :: Int -> CompletionResponseResult -> (Int, CompletionResponseResult) +consumeCompletionResponse n it@(CompletionList (CompletionListType _ (List xx))) = + case splitAt n xx of + (_, []) -> (n - 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 mvf <- LSP.getVirtualFileFunc lf (J.toNormalizedUri uri) From b7c4fd96ca6fe5770f9519d71a33edd6e6149c70 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 13:09:01 +0000 Subject: [PATCH 2/8] Fix pragma completions to prefilter --- haskell-language-server.cabal | 1 + plugins/default/src/Ide/Plugin/Pragmas.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index fbfcd5114f..f2b63b1f71 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 32873a39a8..db08bc5249 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/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 [] From 2c7cba2eebff3ddce43ad580848a1f6996b628bb Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 13:09:11 +0000 Subject: [PATCH 3/8] Fix a completion test --- test/functional/Completion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index a3e7e149a4..a082d2019c 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -116,7 +116,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" From 2b6230ee3db71b713829d3b8774906bb8e7fc94a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 13:15:47 +0000 Subject: [PATCH 4/8] Add a test --- test/functional/Completion.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index a082d2019c..95e8523c46 100644 --- a/test/functional/Completion.hs +++ b/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" [ @@ -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 ] From 97eb2dec3bb151c0bdabc8bcfd4b37672c938cc6 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 15:37:18 +0000 Subject: [PATCH 5/8] Fix another inaccurate test --- test/functional/Completion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 95e8523c46..641b38bbc5 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -104,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" From 9e10a197b1c9d62653775c356849fa7046297757 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 21:00:45 +0000 Subject: [PATCH 6/8] rename n to limit --- ghcide/src/Development/IDE/Plugin/HLS.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 0527043ed1..ae175dcbc4 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -457,17 +457,17 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier IO [Either ResponseError CompletionResponseResult] makeAction 0 _ = return [] makeAction _ [] = return [] - makeAction n ((pid, p) : rest) = do + makeAction limit ((pid, p) : rest) = do pluginConfig <- getPluginConfig lf pid results <- if pluginEnabled pluginConfig plcCompletionOn then otTracedProvider pid "completions" $ p lf ideState params else return $ Right $ Completions $ List [] case results of Right resp -> do - let (n', results') = consumeCompletionResponse n resp - (Right results' :) <$> makeAction n' rest + let (limit', results') = consumeCompletionResponse limit resp + (Right results' :) <$> makeAction limit' rest Left err -> - (Left err :) <$> makeAction n rest + (Left err :) <$> makeAction limit rest case mprefix of Nothing -> return $ Right $ Completions $ List [] @@ -479,9 +479,8 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier -- | Crops a completion response. Returns the final number of completions and the cropped response consumeCompletionResponse :: Int -> CompletionResponseResult -> (Int, CompletionResponseResult) -consumeCompletionResponse n it@(CompletionList (CompletionListType _ (List xx))) = - case splitAt n xx of - (_, []) -> (n - length xx, it) +consumeCompletionResponse limit it@(CompletionList (CompletionListType _ (List xx))) = + case splitAt limit xx of (xx', _) -> (0, CompletionList (CompletionListType False (List xx'))) consumeCompletionResponse n (Completions (List xx)) = consumeCompletionResponse n (CompletionList (CompletionListType False (List xx))) From ed1dc68e04bb29728c8f3623026e313a5ff327ca Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 21:15:52 +0000 Subject: [PATCH 7/8] Evaluate completion providers in parallel --- ghcide/src/Development/IDE/Plugin/HLS.hs | 26 ++++++++---------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index ae175dcbc4..b8985a4235 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -34,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) -- --------------------------------------------------------------------- @@ -437,7 +438,7 @@ makeCompletions :: [(PluginId, CompletionProvider IdeState)] makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) = do mprefix <- getPrefixAtPos lf doc pos - config <- getClientConfig lf + maxCompletions <- maxCompletions <$> getClientConfig lf let combine :: [CompletionResponseResult] -> CompletionResponseResult @@ -450,37 +451,28 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier go comp acc (CompletionList (CompletionListType comp' (List ls)) : rest) = go (comp && comp') (acc <> DList.fromList ls) rest - -- | Process a list of completion providers until we reach a max number of results makeAction :: - Int -> - [(PluginId, CompletionProvider IdeState)] -> - IO [Either ResponseError CompletionResponseResult] - makeAction 0 _ = return [] - makeAction _ [] = return [] - makeAction limit ((pid, p) : rest) = do + (PluginId, CompletionProvider IdeState) -> + IO (Either ResponseError CompletionResponseResult) + makeAction (pid, p) = do pluginConfig <- getPluginConfig lf pid - results <- if pluginEnabled pluginConfig plcCompletionOn + if pluginEnabled pluginConfig plcCompletionOn then otTracedProvider pid "completions" $ p lf ideState params else return $ Right $ Completions $ List [] - case results of - Right resp -> do - let (limit', results') = consumeCompletionResponse limit resp - (Right results' :) <$> makeAction limit' rest - Left err -> - (Left err :) <$> makeAction limit rest case mprefix of Nothing -> return $ Right $ Completions $ List [] Just _prefix -> do - mhs <- makeAction (maxCompletions config) 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))) From 35c036543eedefcbcde6861c4b42392a713a5504 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Jan 2021 21:17:21 +0000 Subject: [PATCH 8/8] Evaluate all HLS providers concurrently --- ghcide/src/Development/IDE/Plugin/HLS.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index b8985a4235..94166ebe4b 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -99,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 @@ -173,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 @@ -308,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 @@ -363,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 @@ -393,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