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..94166ebe4b 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 @@ -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 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 [] diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index a3e7e149a4..641b38bbc5 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" [ @@ -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 ]