Adapt to lsp changes for workspace/configuration

This has a few substantive changes and a lot of messing with tests.

- We now tell `lsp` our config section, and parse just that section.
- We move the logic for updating the shake build rules for client config
  from a `workspace/didChangeConfiguration` handler to the new `lsp`
  callback, which will ensure it gets called in all circumstances that
  can be relevant.

The test changes are more annoying:
- We ignore config and logging messages by default now, so we have to
  stop doing that when we care about it.
- Many tests didn't really need to _change_ the config, but rather just
  to set it once at the beginning. I adjusted a lot of test functions to
  allow passing in the initial config for this reason.

Author: michaelpj

cabal.project

@@ -102,3 +102,8 @@ if impl(ghc >= 9.5)
     ekg-core:ghc-prim,
     stm-hamt:transformers,
 
+source-repository-package
+  type:git
+  location: https://github.com/haskell/lsp
+  tag: 9e756f9cbc6d4e74c6ec988f22f5f8617a1eaef1
+  subdir: lsp lsp-test

exe/Wrapper.hs

@@ -283,7 +283,8 @@ launchErrorLSP recorder errorMsg = do
 
   outH <- Main.argsHandleOut defaultArguments
 
-  let onConfigurationChange cfg _ = Right cfg
+  let parseConfig cfg _ = Right cfg
+      onConfigChange _ = pure ()
 
   let setup clientMsgVar = do
         -- Forcefully exit
@@ -311,7 +312,8 @@ launchErrorLSP recorder errorMsg = do
     inH
     outH
     (Main.argsDefaultHlsConfig defaultArguments)
-    onConfigurationChange
+    parseConfig
+    onConfigChange
     setup
 
 exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c)

flake.lock

@@ -363,8 +363,8 @@ runBenchmarksFun dir allBenchmarks = do
       createDirectoryIfMissing True eventlogDir
 
   lspConfig <- if Experiments.Types.lspConfig ?config
-    then either error Just . eitherDecodeStrict' <$> BS.getContents
-    else return Nothing
+    then either error id . eitherDecodeStrict' <$> BS.getContents
+    else return mempty
 
   let conf = defaultConfig
         { logStdErr = verbose ?config,
@@ -512,7 +512,7 @@ waitForProgressStart :: Session ()
 waitForProgressStart = void $ do
     skipManyTill anyMessage $ satisfy $ \case
       FromServerMess SMethod_WindowWorkDoneProgressCreate _ -> True
-      _                                              -> False
+      _                                                     -> False
 
 -- | Wait for all progress to be done
 -- Needs at least one progress done notification to return

ghcide-bench/src/Experiments.hs

@@ -475,7 +475,8 @@ data GetModSummary = GetModSummary
 instance Hashable GetModSummary
 instance NFData   GetModSummary
 
--- | Get the vscode client settings stored in the ide state
+-- See Note [Client configuration in Rules]
+-- | Get the client config stored in the ide state
 data GetClientSettings = GetClientSettings
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetClientSettings
@@ -510,3 +511,33 @@ instance NFData   GhcSessionIO
 makeLensesWith
     (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
     ''Splices
+
+{- Note [Client configuration in Rules]
+The LSP client configuration is stored by `lsp` for us, and is accesible in
+handlers through the LspT monad.
+
+This is all well and good, but what if we want to write a Rule that depends
+on the configuration? For example, we might have a plugin that provides
+diagnostics - if the configuration changes to turn off that plugin, then
+we need to invalidate the Rule producing the diagnostics so that they go
+away. More broadly, any time we define a Rule that really depends on the
+configuration, such that the dependency needs to be tracked and the Rule
+invalidated when the configuration changes, we have a problem.
+
+The solution is that we have to mirror the configuration into the state
+that our build system knows about. That means that:
+- We have a parallel record of the state in 'IdeConfiguration'
+- We install a callback so that when the config changes we can update the
+'IdeConfiguration' and mark the rule as dirty.
+
+Then we can define a Rule that gets the configuration, and build Actions
+on top of that that behave properly. However, these should really only
+be used if you need the dependency tracking - for normal usage in handlers
+the config can simply be accessed directly from LspT.
+
+TODO(michaelpj): this is me writing down what I think the logic is, but
+it doesn't make much sense to me. In particular, we *can* get the LspT
+in an Action. So I don't know why we need to store it twice. We would
+still need to invalidate the Rule otherwise we won't know it's changed,
+though. See https://github.com/haskell/ghcide/pull/731 for some context.
+-}

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -1095,6 +1095,7 @@ writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do
       (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts
       pure (diags++diags', res)
 
+-- See Note [Client configuration in Rules]
 getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()
 getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do
   alwaysRerun

ghcide/src/Development/IDE/Core/Rules.hs

@@ -325,6 +325,7 @@ getShakeExtrasRules = do
       -- This will actually crash HLS
       Nothing -> liftIO $ fail "missing ShakeExtras"
 
+-- See Note [Client configuration in Rules]
 -- | Returns the client configuration, creating a build dependency.
 --   You should always use this function when accessing client configuration
 --   from build rules.

ghcide/src/Development/IDE/Core/Shake.hs

@@ -90,32 +90,33 @@ runLanguageServer
     -> Handle -- output
     -> config
     -> (config -> Value -> Either T.Text config)
+    -> (config -> m config ())
     -> (MVar ()
         -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)),
                LSP.Handlers (m config),
                (LanguageContextEnv config, a) -> m config <~> IO))
     -> IO ()
-runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do
+runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do
     -- This MVar becomes full when the server thread exits or we receive exit message from client.
     -- LSP server will be canceled when it's full.
     clientMsgVar <- newEmptyMVar
 
     (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar
 
     let serverDefinition = LSP.ServerDefinition
-            { LSP.onConfigurationChange = onConfigurationChange
+            { LSP.parseConfig = parseConfig
+            , LSP.onConfigChange = onConfigChange
             , LSP.defaultConfig = defaultConfig
+            -- TODO: magic string
+            , LSP.configSection = "haskell"
             , LSP.doInitialize = doInitialize
             , LSP.staticHandlers = (const staticHandlers)
             , LSP.interpretHandler = interpretHandler
             , LSP.options = modifyOptions options
             }
 
     let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)
-        lspCologAction = toCologActionWithPrio $ cfilter
-            -- filter out bad logs in lsp, see: https://github.com/haskell/lsp/issues/447
-            (\msg -> priority msg >= Info)
-            (cmapWithPrio LogLspServer recorder)
+        lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder)
 
     void $ untilMVar clientMsgVar $
           void $ LSP.runServerWithHandles

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -32,12 +32,10 @@ import           Development.IDE.Core.FileStore        (registerFileWatches,
 import qualified Development.IDE.Core.FileStore        as FileStore
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest       hiding (Log, LogShake)
-import           Development.IDE.Core.RuleTypes        (GetClientSettings (..))
 import           Development.IDE.Core.Service          hiding (Log, LogShake)
 import           Development.IDE.Core.Shake            hiding (Log, Priority)
 import qualified Development.IDE.Core.Shake            as Shake
 import           Development.IDE.Types.Location
-import           Development.IDE.Types.Shake           (toKey)
 import           Ide.Logger
 import           Ide.Types
 import           Numeric.Natural
@@ -119,12 +117,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa
           $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))
           . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))
 
-  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $
-      \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do
-        let msg = Text.pack $ show cfg
-        logDebug (ideLogger ide) $ "Configuration changed: " <> msg
-        modifyClientSettings ide (const $ Just cfg)
-        setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change"
+  -- Nothing additional to do here beyond what `lsp` does for us, but this prevents
+  -- complaints about there being no handler defined
+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty
 
   , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do
       --------- Initialize Shake session --------------------------------------------------------------------

ghcide/src/Development/IDE/LSP/Notifications.hs

@@ -13,12 +13,16 @@ module Development.IDE.Main
 ) where
 
 import           Control.Concurrent.Extra                 (withNumCapabilities)
+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)
+import           Control.Monad.IO.Class                   (liftIO)
+import qualified Data.Aeson                               as J
 import           Data.Coerce                              (coerce)
 import           Data.Default                             (Default (def))
 import           Data.Foldable                            (traverse_)
@@ -31,11 +35,14 @@ import           Data.Maybe                               (catMaybes, isJust)
 import qualified Data.Text                                as T
 import           Development.IDE                          (Action,
                                                            Priority (Debug, Error),
-                                                           Rules, hDuplicateTo')
+                                                           Rules, emptyFilePath,
+                                                           hDuplicateTo')
 import           Development.IDE.Core.Debouncer           (Debouncer,
                                                            newAsyncDebouncer)
-import           Development.IDE.Core.FileStore           (isWatchSupported)
+import           Development.IDE.Core.FileStore           (isWatchSupported,
+                                                           setSomethingModified)
 import           Development.IDE.Core.IdeConfiguration    (IdeConfiguration (..),
+                                                           modifyClientSettings,
                                                            registerIdeConfiguration)
 import           Development.IDE.Core.OfInterest          (FileOfInterestStatus (OnDisk),
                                                            kick,
@@ -83,7 +90,7 @@ import           Development.IDE.Types.Options            (IdeGhcSession,
                                                            defaultIdeOptions,
                                                            optModifyDynFlags,
                                                            optTesting)
-import           Development.IDE.Types.Shake              (WithHieDb)
+import           Development.IDE.Types.Shake              (WithHieDb, toKey)
 import           GHC.Conc                                 (getNumProcessors)
 import           GHC.IO.Encoding                          (setLocaleEncoding)
 import           GHC.IO.Handle                            (hDuplicate)
@@ -95,8 +102,8 @@ import           Ide.Logger                               (Logger,
                                                            Recorder,
                                                            WithPriority,
                                                            cmapWithPrio,
-                                                           logWith, nest, vsep,
-                                                           (<+>))
+                                                           logDebug, logWith,
+                                                           nest, vsep, (<+>))
 import           Ide.Plugin.Config                        (CheckParents (NeverCheck),
                                                            Config, checkParents,
                                                            checkProject,
@@ -289,7 +296,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
         hlsCommands = allLspCmdIds' pid argsHlsPlugins
         plugins = hlsPlugin <> argsGhcidePlugin
         options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }
-        argsOnConfigChange = getConfigFromNotification argsHlsPlugins
+        argsParseConfig = getConfigFromNotification argsHlsPlugins
         rules = argsRules >> pluginRules plugins
 
     debouncer <- argsDebouncer
@@ -304,6 +311,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             ioT <- offsetTime
             logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
 
+            ideStateVar <- newEmptyMVar
             let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
                 getIdeState env rootPath withHieDb hieChan = do
                   traverse_ IO.setCurrentDirectory rootPath
@@ -334,7 +342,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                               }
                       caps = LSP.resClientCapabilities env
                   monitoring <- argsMonitoring
-                  initialise
+                  ide <- initialise
                       (cmapWithPrio LogService recorder)
                       argsDefaultHlsConfig
                       argsHlsPlugins
@@ -346,10 +354,24 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                       withHieDb
                       hieChan
                       monitoring
+                  putMVar ideStateVar ide
+                  pure ide
 
             let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState
-
-            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup
+                -- See Note [Client configuration in Rules]
+                onConfigChange cfg = do
+                  -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint
+                  let cfgObj = J.toJSON cfg
+                  mide <- liftIO $ tryReadMVar ideStateVar
+                  case mide of
+                    Nothing -> pure ()
+                    Just ide -> liftIO $ do
+                        let msg = T.pack $ show cfg
+                        logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg
+                        modifyClientSettings ide (const $ Just cfgObj)
+                        setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change"
+
+            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup
             dumpSTMStats
         Check argFiles -> do
           dir <- maybe IO.getCurrentDirectory return argsProjectRoot