diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index fd48d86ae6..f5190e9274 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -10,7 +10,10 @@ module Development.IDE.Plugin.HLS ) where import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad +import qualified Control.Monad.Extra as Extra +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Except (runExceptT) import qualified Data.Aeson as A import Data.Bifunctor (first) @@ -22,7 +25,7 @@ import qualified Data.List as List import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (isNothing, mapMaybe) import Data.Some import Data.String import Data.Text (Text) @@ -39,6 +42,7 @@ import Ide.Plugin.Error import Ide.Plugin.HandleRequestTypes import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS +import qualified Language.LSP.Protocol.Lens as JL import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP @@ -58,6 +62,7 @@ data Log | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException + | LogResolveDefaultHandler (Some SMethod) instance Pretty Log where pretty = \case @@ -71,6 +76,8 @@ instance Pretty Log where ExceptionInPlugin plId (Some method) exception -> "Exception in plugin " <> viaShow plId <> " while processing " <> pretty method <> ": " <> viaShow exception + LogResolveDefaultHandler (Some method) -> + "No plugin can handle" <+> pretty method <+> "request. Return object unchanged." instance Show Log where show = renderString . layoutCompact . pretty noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c) @@ -250,8 +257,16 @@ extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers } let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs' let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest m params desc config)) <$> dfs -- Clients generally don't display ResponseErrors so instead we log any that we come across + -- However, some clients do display ResponseErrors! See for example the issues: + -- https://github.com/haskell/haskell-language-server/issues/4467 + -- https://github.com/haskell/haskell-language-server/issues/4451 case nonEmpty fs of - Nothing -> liftIO $ noPluginHandles recorder m disabledPluginsReason + Nothing -> do + liftIO (fallbackResolveHandler recorder m params) >>= \case + Nothing -> + liftIO $ noPluginHandles recorder m disabledPluginsReason + Just result -> + pure $ Right result Just neFs -> do let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params @@ -272,6 +287,72 @@ extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers } Just xs -> do pure $ Right $ combineResponses m config caps params xs +-- | Fallback Handler for resolve requests. +-- For all kinds of `*/resolve` requests, if they don't have a 'data_' value, +-- produce the original item, since no other plugin has any resolve data. +-- +-- This is an internal handler, so it cannot be turned off and should be opaque +-- to the end-user. +-- This function does not take the ServerCapabilities into account, and assumes +-- clients will only send these requests, if and only if the Language Server +-- advertised support for it. +-- +-- See Note [Fallback Handler for LSP resolve requests] for justification and reasoning. +fallbackResolveHandler :: MonadIO m => Recorder (WithPriority Log) -> SMethod s -> MessageParams s -> m (Maybe (MessageResult s)) +fallbackResolveHandler recorder m params = do + let result = case m of + SMethod_InlayHintResolve + | noResolveData params -> Just params + SMethod_CompletionItemResolve + | noResolveData params -> Just params + SMethod_CodeActionResolve + | noResolveData params -> Just params + SMethod_WorkspaceSymbolResolve + | noResolveData params -> Just params + SMethod_CodeLensResolve + | noResolveData params -> Just params + SMethod_DocumentLinkResolve + | noResolveData params -> Just params + _ -> Nothing + logResolveHandling result + pure result + where + noResolveData :: JL.HasData_ p (Maybe a) => p -> Bool + noResolveData p = isNothing $ p ^. JL.data_ + + -- We only log if we are handling the request. + -- If we don't handle this request, this should be logged + -- on call-site. + logResolveHandling p = Extra.whenJust p $ \_ -> do + logWith recorder Debug $ LogResolveDefaultHandler (Some m) + +{- Note [Fallback Handler for LSP resolve requests] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We have a special fallback for `*/resolve` requests. + +We had multiple reports, where `resolve` requests (such as +`completion/resolve` and `codeAction/resolve`) are rejected +by HLS since the `_data_` field of the respective LSP feature has not been +populated by HLS. +This makes sense, as we only support `resolve` for certain kinds of +`CodeAction`/`Completions`, when they contain particularly expensive +properties, such as documentation or non-local type signatures. + +So what to do? We can see two options: + +1. Be dumb and permissive: if no plugin wants to resolve a request, then + just respond positively with the original item! Potentially this masks + real issues, but may not be too bad. If a plugin thinks it can + handle the request but it then fails to resolve it, we should still return a failure. +2. Try and be smart: we try to figure out requests that we're "supposed" to + resolve (e.g. those with a data field), and fail if no plugin wants to handle those. + This is possible since we set data. + So as long as we maintain the invariant that only things which need resolving get + data, then it could be okay. + +In 'fallbackResolveHandler', we implement the option (2). +-} -- --------------------------------------------------------------------- diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs index 8b90244b76..a980d47233 100644 --- a/ghcide/test/exe/CompletionTests.hs +++ b/ghcide/test/exe/CompletionTests.hs @@ -563,13 +563,10 @@ completionDocTests = _ <- waitForDiagnostics compls <- getCompletions doc pos rcompls <- forM compls $ \item -> do - if isJust (item ^. L.data_) - then do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - else pure item + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x let compls' = [ -- We ignore doc uris since it points to the local path which determined by specific machines case mn of diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 75e33d3579..19ae47c67b 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -5,6 +5,8 @@ module Config( mkIdeTestFs , dummyPlugin + -- * runners for testing specific plugins + , testSessionWithPlugin -- * runners for testing with dummy plugin , runWithDummyPlugin , testWithDummyPlugin @@ -34,6 +36,7 @@ import Control.Monad (unless) import Data.Foldable (traverse_) import Data.Function ((&)) import qualified Data.Text as T +import Development.IDE (Pretty) import Development.IDE.Test (canonicalizeUri) import Ide.Types (defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L @@ -49,6 +52,16 @@ testDataDir = "ghcide" "test" "data" mkIdeTestFs :: [FS.FileTree] -> FS.VirtualFileTree mkIdeTestFs = FS.mkVirtualFileTree testDataDir +-- * Run with some injected plugin +-- testSessionWithPlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +testSessionWithPlugin :: Pretty b => FS.VirtualFileTree -> PluginTestDescriptor b -> (FilePath -> Session a) -> IO a +testSessionWithPlugin fs plugin = runSessionWithTestConfig def + { testPluginDescriptor = plugin + , testDirLocation = Right fs + , testConfigCaps = lspTestCaps + , testShiftRoot = True + } + -- * A dummy plugin for testing ghcIde dummyPlugin :: PluginTestDescriptor () dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core" diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6bca4245be..c8d927072c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -59,6 +59,7 @@ import PluginSimpleTests import PositionMappingTests import PreprocessorTests import ReferenceTests +import ResolveTests import RootUriTests import SafeTests import SymlinkTests @@ -98,6 +99,7 @@ main = do , AsyncTests.tests , ClientSettingsTests.tests , ReferenceTests.tests + , ResolveTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests diff --git a/ghcide/test/exe/ResolveTests.hs b/ghcide/test/exe/ResolveTests.hs new file mode 100644 index 0000000000..b247107651 --- /dev/null +++ b/ghcide/test/exe/ResolveTests.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +module ResolveTests (tests) where + +import Config +import Control.Lens +import Data.Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics +import Ide.Logger +import Ide.Types (PluginDescriptor (..), PluginId, + defaultPluginDescriptor, + mkPluginHandler, + mkResolveHandler) +import qualified Language.LSP.Protocol.Lens as J +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Message (SomeMethod (..)) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import Language.LSP.Test +import Test.Hls (IdeState, SMethod (..), liftIO, + mkPluginTestDescriptor, + someMethodToMethodString, + waitForAllProgressDone) +import qualified Test.Hls.FileSystem as FS +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "resolve" + [ testGroup "with and without data" resolveRequests + ] + +removeData :: JL.HasData_ s (Maybe a) => s -> s +removeData param = param & JL.data_ .~ Nothing + +simpleTestSession :: TestName -> Session () -> TestTree +simpleTestSession name act = + testCase name $ runWithResolvePlugin (mkIdeTestFs [FS.directCradle ["A.hs"]]) (const act) + +runWithResolvePlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +runWithResolvePlugin fs = + testSessionWithPlugin fs + (mkPluginTestDescriptor resolvePluginDescriptor "resolve-plugin") + +data CompletionItemResolveData = CompletionItemResolveData + { completionItemResolve_number :: Int + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data CodeActionResolve = CodeActionResolve + { codeActionResolve_number :: Int + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data CodeLensResolve = CodeLensResolve + { codeLensResolve_number :: Int + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +resolvePluginDescriptor :: Recorder (WithPriority Text) -> PluginId -> PluginDescriptor IdeState +resolvePluginDescriptor recorder pid = (defaultPluginDescriptor pid "Test Plugin for Resolve Requests") + { pluginHandlers = mconcat + [ mkResolveHandler LSP.SMethod_CompletionItemResolve $ \_ _ param _ CompletionItemResolveData{} -> pure param + , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ \_ _ _ -> do + pure $ InL + [ defCompletionItem "test item without data" + , defCompletionItem "test item with data" + & J.data_ .~ Just (toJSON $ CompletionItemResolveData 100) + ] + , mkResolveHandler LSP.SMethod_CodeActionResolve $ \_ _ param _ CodeActionResolve{} -> pure param + , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ \_ _ _ -> do + logWith recorder Debug "Why is the handler not called?" + pure $ InL + [ InR $ defCodeAction "test item without data" + , InR $ defCodeAction "test item with data" + & J.data_ .~ Just (toJSON $ CodeActionResolve 70) + ] + , mkResolveHandler LSP.SMethod_CodeLensResolve $ \_ _ param _ CodeLensResolve{} -> pure param + , mkPluginHandler LSP.SMethod_TextDocumentCodeLens $ \_ _ _ -> do + pure $ InL + [ defCodeLens "test item without data" + , defCodeLens "test item with data" + & J.data_ .~ Just (toJSON $ CodeLensResolve 50) + ] + ] + } + +resolveRequests :: [TestTree] +resolveRequests = + [ simpleTestSession "completion resolve" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "data Foo = Foo { foo :: Int }" + , "bar = Foo 4" + ] + waitForAllProgressDone + items <- getCompletions doc (Position 2 7) + let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items + liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems) + -- This must not throw an error. + _ <- traverse (resolveCompletion . removeData) resolveCompItems + pure () + , simpleTestSession "codeAction resolve" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "data Foo = Foo { foo :: Int }" + , "bar = Foo 4" + ] + waitForAllProgressDone + -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic + -- locations and we don't have diagnostics in these tests. + cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0)) + let resolveCas = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.title)) cas + liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCas) + -- This must not throw an error. + _ <- traverse (resolveCodeAction . removeData) resolveCas + pure () + , simpleTestSession "codelens resolve" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "data Foo = Foo { foo :: Int }" + , "bar = Foo 4" + ] + waitForAllProgressDone + cd <- getCodeLenses doc + let resolveCodeLenses = filter (\i -> case i ^. J.command of + Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title) + Nothing -> False + ) cd + liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCodeLenses) + -- This must not throw an error. + _ <- traverse (resolveCodeLens . removeData) resolveCodeLenses + pure () + ] + +defCompletionItem :: T.Text -> CompletionItem +defCompletionItem lbl = CompletionItem + { _label = lbl + , _labelDetails = Nothing + , _kind = Nothing + , _tags = Nothing + , _detail = Nothing + , _documentation = Nothing + , _deprecated = Nothing + , _preselect = Nothing + , _sortText = Nothing + , _filterText = Nothing + , _insertText = Just "insertion" + , _insertTextFormat = Nothing + , _insertTextMode = Nothing + , _textEdit = Nothing + , _textEditText = Nothing + , _additionalTextEdits = Nothing + , _commitCharacters = Nothing + , _command = Nothing + , _data_ = Nothing + } + +defCodeAction :: T.Text -> CodeAction +defCodeAction lbl = CodeAction + { _title = lbl + , _kind = Just CodeActionKind_Refactor + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Nothing + , _command = Just $ Command + { _title = lbl + , _command = lbl + , _arguments = Nothing + } + , _data_ = Nothing + } + +defCodeLens :: T.Text -> CodeLens +defCodeLens lbl = CodeLens + { _range = mkRange 0 0 1 0 + , _command = Just $ Command + { _title = lbl + , _command = lbl + , _arguments = Nothing + } + , _data_ = Nothing + } + +-- TODO: expose this from lsp-test +resolveCompletion :: CompletionItem -> Session CompletionItem +resolveCompletion item = do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. JL.result of + Left err -> liftIO $ assertFailure (someMethodToMethodString (SomeMethod SMethod_CompletionItemResolve) <> " failed with: " <> show err) + Right x -> pure x diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 08f58f64c4..dcbb546733 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2208,6 +2208,7 @@ test-suite ghcide-tests PreprocessorTests Progress ReferenceTests + ResolveTests RootUriTests SafeTests SymlinkTests