mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-19 04:37:25 +03:00
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
This commit is contained in:
Pepe Iborra
GitHub
parent
15c070c03f
commit
e06469f2b4
@ -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 [])
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 []
|
||||
|
||||
@ -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
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user