Merge branch 'master' into batch-load-multi-read

.github/actions/setup-build/action.yml

@@ -31,7 +31,7 @@ runs:
         sudo chown -R $USER /usr/local/.ghcup
       shell: bash
 
-    - uses: haskell-actions/[email protected].8
+    - uses: haskell-actions/[email protected].9
       id: HaskEnvSetup
       with:
         ghc-version  : ${{ inputs.ghc   }}

.github/workflows/bench.yml

@@ -127,7 +127,7 @@ jobs:
         example: ['cabal', 'lsp-types']
 
     steps:
-    - uses: haskell-actions/[email protected].8
+    - uses: haskell-actions/[email protected].9
       with:
         ghc-version  : ${{ matrix.ghc   }}
         cabal-version: ${{ matrix.cabal }}

cabal.project

@@ -17,6 +17,12 @@ benchmarks: True
 
 write-ghc-environment-files: never
 
+-- Link executables dynamically so the linker doesn't produce test
+-- executables of ~150MB each and works lightning fast at that too
+-- Disabled on Windows
+if(!os(windows))
+  executable-dynamic: True
+
 -- Many of our tests only work single-threaded, and the only way to
 -- ensure tasty runs everything purely single-threaded is to pass
 -- this at the top-level

ghcide/session-loader/Development/IDE/Session.hs

@@ -8,7 +8,7 @@ module Development.IDE.Session
   (SessionLoadingOptions(..)
   ,CacheDirs(..)
   ,loadSessionWithOptions
-  ,setInitialDynFlags
+  ,getInitialGhcLibDirDefault
   ,getHieDbLoc
   ,retryOnSqliteBusy
   ,retryOnException
@@ -113,7 +113,6 @@ import           Development.IDE.Types.Shake         (WithHieDb,
 import           GHC.Data.Graph.Directed
 import           HieDb.Create
 import           HieDb.Types
-import           HieDb.Utils
 import           Ide.PluginUtils                     (toAbsolute)
 import qualified System.Random                       as Random
 import           System.Random                       (RandomGen)
@@ -303,15 +302,6 @@ getInitialGhcLibDirDefault recorder rootDir = do
         logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone
         pure Nothing
 
--- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
-setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
-setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do
-  libdir <- getInitialGhcLibDir recorder rootDir
-  dynFlags <- mapM dynFlagsForPrinting libdir
-  logWith recorder Debug LogSettingInitialDynFlags
-  mapM_ setUnsafeGlobalDynFlags dynFlags
-  pure libdir
-
 -- | If the action throws exception that satisfies predicate then we sleep for
 -- a duration determined by the random exponential backoff formula,
 -- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try

ghcide/src/Development/IDE/GHC/Util.hs

@@ -255,7 +255,6 @@ ioe_dupHandlesNotCompatible h =
 -- Tracing exactprint terms
 
 -- | Print a GHC value in `defaultUserStyle` without unique symbols.
--- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally.
 --
 -- This is the most common print utility.
 -- It will do something additionally compared to what the 'Outputable' instance does.

ghcide/src/Development/IDE/Main.hs

@@ -16,7 +16,6 @@ import           Control.Concurrent.MVar                  (newEmptyMVar,
                                                            putMVar, tryReadMVar)
 import           Control.Concurrent.STM.Stats             (dumpSTMStats)
 import           Control.Exception.Safe                   (SomeException,
-                                                           catchAny,
                                                            displayException)
 import           Control.Monad.Extra                      (concatMapM, unless,
                                                            when)
@@ -32,7 +31,7 @@ import           Data.List.Extra                          (intercalate,
 import           Data.Maybe                               (catMaybes, isJust)
 import qualified Data.Text                                as T
 import           Development.IDE                          (Action,
-                                                           Priority (Debug, Error),
+                                                           Priority (Debug),
                                                            Rules, hDuplicateTo')
 import           Development.IDE.Core.Debouncer           (Debouncer,
                                                            newAsyncDebouncer)
@@ -72,9 +71,9 @@ import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde
 import qualified Development.IDE.Plugin.Test              as Test
 import           Development.IDE.Session                  (SessionLoadingOptions,
                                                            getHieDbLoc,
+                                                           getInitialGhcLibDirDefault,
                                                            loadSessionWithOptions,
-                                                           retryOnSqliteBusy,
-                                                           setInitialDynFlags)
+                                                           retryOnSqliteBusy)
 import qualified Development.IDE.Session                  as Session
 import           Development.IDE.Types.Location           (NormalizedUri,
                                                            toNormalizedFilePath')
@@ -136,7 +135,6 @@ data Log
   | LogLspStart [PluginId]
   | LogLspStartDuration !Seconds
   | LogShouldRunSubset !Bool
-  | LogSetInitialDynFlagsException !SomeException
   | LogConfigurationChange T.Text
   | LogService Service.Log
   | LogShake Shake.Log
@@ -160,8 +158,6 @@ instance Pretty Log where
       "Started LSP server in" <+> pretty (showDuration duration)
     LogShouldRunSubset shouldRunSubset ->
       "shouldRunSubset:" <+> pretty shouldRunSubset
-    LogSetInitialDynFlagsException e ->
-      "setInitialDynFlags:" <+> pretty (displayException e)
     LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg
     LogService msg -> pretty msg
     LogShake msg -> pretty msg
@@ -329,13 +325,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                 getIdeState env rootPath withHieDb threadQueue = do
                   t <- ioT
                   logWith recorder Info $ LogLspStartDuration t
-                  -- We want to set the global DynFlags right now, so that we can use
-                  -- `unsafeGlobalDynFlags` even before the project is configured
-                  _mlibdir <-
-                      setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions
-                          -- TODO: should probably catch/log/rethrow at top level instead
-                          `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)
-
                   sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue)
                   config <- LSP.runLspT env LSP.getConfig
                   let def_options = argsIdeOptions config sessionLoader
@@ -435,7 +424,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             let root = argsProjectRoot
             dbLoc <- getHieDbLoc root
             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
-            mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def
+            mlibdir <- getInitialGhcLibDirDefault (cmapWithPrio LogSession recorder) root
             rng <- newStdGen
             case mlibdir of
                 Nothing     -> exitWith $ ExitFailure 1

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