Implement fallback handler for */resolve requests

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).
+-}
 
 -- ---------------------------------------------------------------------
 

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

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"

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