diff --git a/cabal.project b/cabal.project index 971fa012b81..2ee5d278d84 100644 --- a/cabal.project +++ b/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 diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 32f7327e56e..8489c96f3d7 100644 --- a/exe/Wrapper.hs +++ b/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) diff --git a/flake.lock b/flake.lock index 04f2e6a04aa..c3d8f1b878b 100644 --- a/flake.lock +++ b/flake.lock @@ -134,37 +134,37 @@ "lsp": { "flake": false, "locked": { - "narHash": "sha256-H0qJbQQufOOWovqqdJv6GUaL49o7tET8yTkdLKH1qoE=", + "narHash": "sha256-Uq9OLBZFJvg8BM383++3o3s54Trho6gaYor+6EELV38=", "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-2.0.0.0/lsp-2.0.0.0.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-2.1.0.0/lsp-2.1.0.0.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-2.0.0.0/lsp-2.0.0.0.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-2.1.0.0/lsp-2.1.0.0.tar.gz" } }, "lsp-test": { "flake": false, "locked": { - "narHash": "sha256-ac9G/i9JfFKfX7gI57fVirBgW+Np+GDlZ3/4Eb8r6Gc=", + "narHash": "sha256-48gVUVsDPR+RYl+K0ZN15N9EIdTQP8ma5nGPvzE6uoQ=", "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.0/lsp-test-0.15.0.0.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.1/lsp-test-0.15.0.1.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.0/lsp-test-0.15.0.0.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.1/lsp-test-0.15.0.1.tar.gz" } }, "lsp-types": { "flake": false, "locked": { - "narHash": "sha256-ISvkr2CQWWbxcGm62IK+NIVfq6CEzXQhov47f9YdHW4=", + "narHash": "sha256-irO9uob1L10l1BoRC8F2lABqAzR5Z7mydyCZagMZZ2M=", "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-types-2.0.0.1/lsp-types-2.0.0.1.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-types-2.0.1.0/lsp-types-2.0.1.0.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-types-2.0.0.1/lsp-types-2.0.0.1.tar.gz" + "url": "https://hackage.haskell.org/package/lsp-types-2.0.1.0/lsp-types-2.0.1.0.tar.gz" } }, "nixpkgs": { diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 916631e2939..552f4000814 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 252e6cd42fd..30251ee8d3c 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.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. +-} diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 1ce358fb880..ae4e6a44bda 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c413729ab19..82aeb73811c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.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. diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 51ed44f17f3..90175cb7305 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -90,12 +90,13 @@ 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 @@ -103,8 +104,11 @@ runLanguageServer recorder options inH outH defaultConfig onConfigurationChange (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 @@ -112,10 +116,7 @@ runLanguageServer recorder options inH outH defaultConfig onConfigurationChange } 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 diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 16301e57f7d..d0967a25a41 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.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 -------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b1eb16a8fe0..bad9ed7ba77 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.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 diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs index 46efe9e45dc..23bc752f82d 100644 --- a/ghcide/test/exe/ClientSettingsTests.hs +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -4,8 +4,9 @@ module ClientSettingsTests (tests) where import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON) -import qualified Data.Aeson as A +import Data.Default import qualified Data.Text as T +import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), @@ -19,11 +20,11 @@ import TestUtils tests :: TestTree tests = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do + setIgnoringLogNotifications False void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone - sendNotification SMethod_WorkspaceDidChangeConfiguration - (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) + setConfigSection "haskell" $ toJSON (def :: Config) skipManyTill anyMessage restartingBuildSession ] diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 7af4de75acf..818e6953d54 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -45,11 +45,11 @@ addSigLensesTests = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others - createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others - sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + setConfigSection "haskell" (createConfig mode) doc <- createDoc "Sigs.hs" "haskell" originalCode -- Because the diagnostics mode is really relying only on diagnostics now -- to generate the code lens we need to make sure we wait till the file diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 29a47fe49c0..e92e7a43d9e 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -50,7 +50,7 @@ import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic -import GHC.TypeLits ( symbolVal ) +import GHC.TypeLits (symbolVal) import Ide.Plugin.Config (CheckParents, checkProject) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -241,10 +241,7 @@ waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> _ -> Nothing configureCheckProject :: Bool -> Session () -configureCheckProject overrideCheckProject = - sendNotification SMethod_WorkspaceDidChangeConfiguration - (DidChangeConfigurationParams $ toJSON - def{checkProject = overrideCheckProject}) +configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject}) -- | Pattern match a message from ghcide indicating that a file has been indexed isReferenceReady :: FilePath -> Session () diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index afc35296635..785a7a5a929 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -11,17 +11,16 @@ module Ide.Plugin.Config , CheckParents(..) ) where -import Control.Applicative -import Control.Lens (preview) -import Data.Aeson hiding (Error) -import qualified Data.Aeson as A -import Data.Aeson.Lens (_String) -import qualified Data.Aeson.Types as A +import Control.Lens (preview) +import Data.Aeson hiding (Error) +import qualified Data.Aeson as A +import Data.Aeson.Lens (_String) +import qualified Data.Aeson.Types as A import Data.Default -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import GHC.Exts (toList) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import GHC.Exts (toList) import Ide.Types -- --------------------------------------------------------------------- @@ -37,19 +36,14 @@ getConfigFromNotification plugins defaultValue p = -- --------------------------------------------------------------------- parseConfig :: IdePlugins s -> Config -> Value -> A.Parser Config -parseConfig idePlugins defValue = A.withObject "Config" $ \v -> do - -- Officially, we use "haskell" as the section name but for - -- backwards compatibility we also accept "languageServerHaskell" - c <- v .: "haskell" <|> v .:? "languageServerHaskell" - case c of - Nothing -> return defValue - Just s -> flip (A.withObject "Config.settings") s $ \o -> Config - <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue - <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue - <*> o .:? "formattingProvider" .!= formattingProvider defValue - <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue - <*> o .:? "maxCompletions" .!= maxCompletions defValue - <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue +parseConfig idePlugins defValue = A.withObject "settings" $ \o -> + Config + <$> o .:? "checkParents" .!= checkParents defValue + <*> o .:? "checkProject" .!= checkProject defValue + <*> o .:? "formattingProvider" .!= formattingProvider defValue + <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue + <*> o .:? "maxCompletions" .!= maxCompletions defValue + <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue -- | Parse the 'PluginConfig'. -- Since we need to fall back to default values if we do not find one in the input, diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index c3a52952571..6111de4a48c 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -5,7 +5,7 @@ module Ide.Plugin.ConfigUtils where -import Control.Lens (at, ix, (&), (?~)) +import Control.Lens (at, (&), (?~)) import qualified Data.Aeson as A import Data.Aeson.Lens (_Object) import qualified Data.Aeson.Types as A @@ -29,10 +29,9 @@ import Language.LSP.Protocol.Message -- | Generates a default 'Config', but remains only effective items pluginsToDefaultConfig :: IdePlugins a -> A.Value pluginsToDefaultConfig IdePlugins {..} = - -- Use 'ix' to look at all the "haskell" keys in the outer value (since we're not - -- setting it if missing), then we use '_Object' and 'at' to get at the "plugin" key + -- Use '_Object' and 'at' to get at the "plugin" key -- and actually set it. - A.toJSON defaultConfig & ix "haskell" . _Object . at "plugin" ?~ elems + A.toJSON defaultConfig & _Object . at "plugin" ?~ elems where defaultConfig@Config {} = def elems = A.object $ mconcat $ singlePlugin <$> ipMap diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ce7acc2ff5d..9159fc45962 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -179,14 +179,12 @@ data Config = instance ToJSON Config where toJSON Config{..} = - object [ "haskell" .= r ] - where - r = object [ "checkParents" .= checkParents - , "checkProject" .= checkProject - , "formattingProvider" .= formattingProvider - , "maxCompletions" .= maxCompletions - , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins - ] + object [ "checkParents" .= checkParents + , "checkProject" .= checkProject + , "formattingProvider" .= formattingProvider + , "maxCompletions" .= maxCompletions + , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins + ] instance Default Config where def = Config diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 1805a61d826..5d7ab2e8cec 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -28,8 +29,6 @@ module Test.Hls -- * Running HLS for integration tests runSessionWithServer, runSessionWithServerAndCaps, - runSessionWithServerFormatter, - runSessionWithCabalServerFormatter, runSessionWithServer', -- * Helpful re-exports PluginDescriptor, @@ -40,7 +39,8 @@ module Test.Hls waitForBuildQueue, waitForTypecheck, waitForAction, - sendConfigurationChanged, + hlsConfigToClientConfig, + setHlsConfig, getLastBuildKeys, waitForKickDone, waitForKickStart, @@ -134,7 +134,8 @@ goldenGitDiff name = goldenVsStringDiff name gitDiff goldenWithHaskellDoc :: Pretty b - => PluginTestDescriptor b + => Config + -> PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -146,7 +147,8 @@ goldenWithHaskellDoc = goldenWithDoc "haskell" goldenWithHaskellAndCaps :: Pretty b - => ClientCapabilities + => Config + -> ClientCapabilities -> PluginTestDescriptor b -> TestName -> FilePath @@ -155,9 +157,9 @@ goldenWithHaskellAndCaps -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithHaskellAndCaps clientCaps plugin title testDataDir path desc ext act = +goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerAndCaps plugin clientCaps testDataDir + $ runSessionWithServerAndCaps config plugin clientCaps testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -167,7 +169,8 @@ goldenWithHaskellAndCaps clientCaps plugin title testDataDir path desc ext act = goldenWithCabalDoc :: Pretty b - => PluginTestDescriptor b + => Config + -> PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -180,6 +183,7 @@ goldenWithCabalDoc = goldenWithDoc "cabal" goldenWithDoc :: Pretty b => T.Text + -> Config -> PluginTestDescriptor b -> TestName -> FilePath @@ -188,9 +192,9 @@ goldenWithDoc -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithDoc fileType plugin title testDataDir path desc ext act = +goldenWithDoc fileType config plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServer plugin testDataDir + $ runSessionWithServer config plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) fileType @@ -284,33 +288,20 @@ initialiseTestRecorder envVars = do -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ -runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a -runSessionWithServer plugin fp act = do - recorder <- pluginTestRecorder - runSessionWithServer' (plugin recorder) def def fullCaps fp act - -runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCaps plugin caps fp act = do +runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a +runSessionWithServer config plugin fp act = do recorder <- pluginTestRecorder - runSessionWithServer' (plugin recorder) def def caps fp act + runSessionWithServer' (plugin recorder) config def fullCaps fp act -runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a -runSessionWithServerFormatter plugin formatter conf fp act = do +runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a +runSessionWithServerAndCaps config plugin caps fp act = do recorder <- pluginTestRecorder - runSessionWithServer' - (plugin recorder) - def - { formattingProvider = T.pack formatter - , plugins = M.singleton (PluginId $ T.pack formatter) conf - } - def - fullCaps - fp - act + runSessionWithServer' (plugin recorder) config def caps fp act goldenWithHaskellDocFormatter :: Pretty b - => PluginTestDescriptor b -- ^ Formatter plugin to be used + => Config + -> PluginTestDescriptor b -- ^ Formatter plugin to be used -> String -- ^ Name of the formatter to be used -> PluginConfig -> TestName -- ^ Title of the test @@ -320,9 +311,10 @@ goldenWithHaskellDocFormatter -> FilePath -- ^ Extension of the output file -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc ext act = - goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerFormatter plugin formatter conf testDataDir +goldenWithHaskellDocFormatter config plugin formatter conf title testDataDir path desc ext act = + let config' = config { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf } + in goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithServer config' plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -332,7 +324,8 @@ goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc goldenWithCabalDocFormatter :: Pretty b - => PluginTestDescriptor b -- ^ Formatter plugin to be used + => Config + -> PluginTestDescriptor b -- ^ Formatter plugin to be used -> String -- ^ Name of the formatter to be used -> PluginConfig -> TestName -- ^ Title of the test @@ -342,9 +335,10 @@ goldenWithCabalDocFormatter -> FilePath -- ^ Extension of the output file -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithCabalDocFormatter plugin formatter conf title testDataDir path desc ext act = - goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithCabalServerFormatter plugin formatter conf testDataDir +goldenWithCabalDocFormatter config plugin formatter conf title testDataDir path desc ext act = + let config' = config { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf } + in goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithServer config' plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "cabal" @@ -352,19 +346,6 @@ goldenWithCabalDocFormatter plugin formatter conf title testDataDir path desc ex act doc documentContents doc -runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a -runSessionWithCabalServerFormatter plugin formatter conf fp act = do - recorder <- pluginTestRecorder - runSessionWithServer' - (plugin recorder) - def - { cabalFormattingProvider = T.pack formatter - , plugins = M.singleton (PluginId $ T.pack formatter) conf - } - def - fullCaps - fp act - -- | Restore cwd after running an action keepCurrentDirectory :: IO a -> IO a keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const @@ -404,6 +385,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] let + sconf' = sconf { lspConfig = hlsConfigToClientConfig conf } -- exists until old logging style is phased out logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) @@ -429,7 +411,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre , argsIdeOptions = ideOptions } - x <- runSessionWithHandles inW outR sconf caps root s + x <- runSessionWithHandles inW outR sconf' caps root s hClose inW timeout 3 (wait server) >>= \case Just () -> pure () @@ -489,9 +471,19 @@ waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid getLastBuildKeys :: Session (Either ResponseError [T.Text]) getLastBuildKeys = callTestPlugin GetBuildKeysBuilt -sendConfigurationChanged :: Value -> Session () -sendConfigurationChanged config = - sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) +hlsConfigToClientConfig :: Config -> A.Object +hlsConfigToClientConfig config = [("haskell", toJSON config)] + +-- | Set the HLS client configuration, and wait for the server to update to use it. +-- Note that this will only work if we are not ignoring configuration requests, you +-- may need to call @setIgnoringConfigurationRequests False@ first. +setHlsConfig :: Config -> Session () +setHlsConfig config = do + setConfig $ hlsConfigToClientConfig config + -- wait until we get the workspace/configuration request from the server, so + -- we know things are settling. This only works if we're not skipping config + -- requests! + skipManyTill anyMessage (void configurationRequest) waitForKickDone :: Session () waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index 5955247f7a8..6eedae82cee 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -54,7 +54,7 @@ test = testGroup "alternateNumberFormat" [ codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree codeActionProperties fp locs assertions = testCase fp $ do - runSessionWithServer alternateNumberFormatPlugin testDataDir $ do + runSessionWithServer def alternateNumberFormatPlugin testDataDir $ do openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findAlternateNumberActions >>= assertions where -- similar to codeActionTest @@ -75,7 +75,7 @@ testDataDir :: FilePath testDataDir = "test" "testdata" goldenAlternateFormat :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenAlternateFormat fp = goldenWithHaskellDoc alternateNumberFormatPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenAlternateFormat fp = goldenWithHaskellDoc def alternateNumberFormatPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" codeActionTest :: (Maybe Text -> Bool) -> FilePath -> Int -> Int -> TestTree codeActionTest filter' fp line col = goldenAlternateFormat fp $ \doc -> do diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs index 54c95eddb9f..4aa567ac4e2 100644 --- a/plugins/hls-cabal-fmt-plugin/test/Main.hs +++ b/plugins/hls-cabal-fmt-plugin/test/Main.hs @@ -52,7 +52,7 @@ cabalFmtGolden NotFound title _ _ _ = testCase title $ assertFailure $ "Couldn't find cabal-fmt on PATH or this is not an isolated run. " <> "Use cabal flag 'isolateTests' to make it isolated or install cabal-fmt locally." -cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act +cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter def cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act where conf = def diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index 078c05750a4..f6df79cc8be 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -44,7 +44,7 @@ runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir runCabalSession :: FilePath -> Session a -> IO a runCabalSession subdir = - failIfSessionTimeout . runSessionWithServer cabalPlugin (testDataDir subdir) + failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir subdir) testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index a340ae8c829..29d7ffa2793 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -198,7 +198,7 @@ incomingCallsTests = [ testGroup "single file" [ testCase "xdata unavailable" $ - runSessionWithServer plugin testDataDir $ do + runSessionWithServer def plugin testDataDir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (testDataDir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) @@ -323,7 +323,7 @@ outgoingCallsTests = [ testGroup "single file" [ testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> - runSessionWithServer plugin dir $ do + runSessionWithServer def plugin dir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (dir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) @@ -425,7 +425,7 @@ outgoingCallsTests = incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> - runSessionWithServer plugin dir $ do + runSessionWithServer def plugin dir $ do doc <- createDoc "A.hs" "haskell" contents waitForIndex (dir "A.hs") items <- concatMapM (\((x, y), range) -> @@ -445,7 +445,7 @@ incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTemp incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion incomingCallMultiFileTestCase filepath queryX queryY mp = - runSessionWithServer plugin testDataDir $ do + runSessionWithServer def plugin testDataDir $ do doc <- openDoc filepath "haskell" waitForIndex (testDataDir filepath) items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do @@ -467,7 +467,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp = outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> - runSessionWithServer plugin dir $ do + runSessionWithServer def plugin dir $ do doc <- createDoc "A.hs" "haskell" contents waitForIndex (dir "A.hs") items <- concatMapM (\((x, y), range) -> @@ -486,7 +486,7 @@ outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTemp outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion outgoingCallMultiFileTestCase filepath queryX queryY mp = - runSessionWithServer plugin testDataDir $ do + runSessionWithServer def plugin testDataDir $ do doc <- openDoc filepath "haskell" waitForIndex (testDataDir filepath) items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do @@ -507,7 +507,7 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp = oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> - runSessionWithServer plugin dir $ do + runSessionWithServer def plugin dir $ do doc <- createDoc "A.hs" "haskell" contents waitForIndex (dir "A.hs") Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index 0a89571d0bd..53f51a97e7d 100644 --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -15,7 +15,7 @@ import Test.Hls (CodeAction (..), Command, Range (Range), Session, TestName, TestTree, TextDocumentIdentifier, - assertFailure, + assertFailure, def, defaultTestRunner, executeCodeAction, getCodeActions, @@ -91,7 +91,7 @@ testDataDir :: FilePath testDataDir = "test" "testdata" goldenChangeSignature :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenChangeSignature fp = goldenWithHaskellDoc changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenChangeSignature fp = goldenWithHaskellDoc def changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" codeActionTest :: FilePath -> Int -> Int -> TestTree codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do @@ -104,7 +104,7 @@ codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree codeActionProperties fp locs assertions = testCase fp $ do - runSessionWithServer changeTypeSignaturePlugin testDataDir $ do + runSessionWithServer def changeTypeSignaturePlugin testDataDir $ do openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findChangeTypeActions >>= assertions where codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index b102c64f735..7bcdafb33e4 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -81,7 +81,7 @@ codeActionTests = testGroup [ "Add placeholders for 'f','g'" , "Add placeholders for 'f','g' with signature(s)" ] - , testCase "Update text document version" $ runSessionWithServer classPlugin testDataDir $ do + , testCase "Update text document version" $ runSessionWithServer def classPlugin testDataDir $ do doc <- createDoc "Version.hs" "haskell" "module Version where" ver1 <- (^. L.version) <$> getVersionedDoc doc liftIO $ ver1 @?= 0 @@ -109,7 +109,7 @@ codeLensTests :: TestTree codeLensTests = testGroup "code lens" [ testCase "Has code lens" $ do - runSessionWithServer classPlugin testDataDir $ do + runSessionWithServer def classPlugin testDataDir $ do doc <- openDoc "CodeLensSimple.hs" "haskell" lens <- getCodeLenses doc let titles = map (^. L.title) $ mapMaybe (^. L.command) lens @@ -118,7 +118,7 @@ codeLensTests = testGroup , "(==) :: A -> A -> Bool" ] , testCase "No lens for TH" $ do - runSessionWithServer classPlugin testDataDir $ do + runSessionWithServer def classPlugin testDataDir $ do doc <- openDoc "TH.hs" "haskell" lens <- getCodeLenses doc liftIO $ length lens @?= 0 @@ -131,7 +131,7 @@ codeLensTests = testGroup , goldenCodeLens "Qualified name" "Qualified" 0 , goldenCodeLens "Type family" "TypeFamily" 0 , testCase "keep stale lens" $ do - runSessionWithServer classPlugin testDataDir $ do + runSessionWithServer def classPlugin testDataDir $ do doc <- openDoc "Stale.hs" "haskell" oldLens <- getCodeLenses doc let edit = TextEdit (mkRange 4 11 4 12) "" -- Remove the `_` @@ -147,14 +147,14 @@ _CACodeAction = prism' InR $ \case goldenCodeLens :: TestName -> FilePath -> Int -> TestTree goldenCodeLens title path idx = - goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do + goldenWithHaskellDoc def classPlugin title testDataDir path "expected" "hs" $ \doc -> do lens <- getCodeLenses doc executeCommand $ fromJust $ (lens !! idx) ^. L.command void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree goldenWithClass title path desc act = - goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do + goldenWithHaskellDoc def classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions @@ -163,7 +163,7 @@ goldenWithClass title path desc act = expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree expectCodeActionsAvailable title path actionTitles = testCase title $ do - runSessionWithServer classPlugin testDataDir $ do + runSessionWithServer def classPlugin testDataDir $ do doc <- openDoc (path <.> "hs") "haskell" _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) caResults <- getAllCodeActions doc diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 8dc0e713fd2..aebc68ca7ed 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -41,7 +41,7 @@ main = do selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do - res <- runSessionWithServer plugin testDataDir $ do + res <- runSessionWithServer def plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions @@ -71,7 +71,7 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi foldingRangeGoldenTest :: TestName -> TestTree foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do - res <- runSessionWithServer plugin testDataDir $ do + res <- runSessionWithServer def plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc let res = resp ^. result diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index d903421d4f3..1546f901607 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -40,27 +40,27 @@ tests :: TestTree tests = testGroup "eval" [ testCase "Produces Evaluate code lenses" $ - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc "T3.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] @@ -212,7 +212,7 @@ tests = not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" ] , testCase "Interfaces are reused after Eval" $ do - runSessionWithServer evalPlugin testDataDir $ do + runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc "TLocalImport.hs" "haskell" waitForTypecheck doc lenses <- getCodeLenses doc @@ -231,13 +231,13 @@ tests = goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = - goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards + goldenWithHaskellDoc def evalPlugin title testDataDir path "expected" ext executeLensesBackwards -- | Similar function as 'goldenWithEval' with an alternate reference file -- naming. Useful when reference file may change because of GHC version. goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree goldenWithEval' title path ext expected = - goldenWithHaskellDoc evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDoc def evalPlugin title testDataDir path expected ext executeLensesBackwards -- | Execute lenses backwards, to avoid affecting their position in the source file executeLensesBackwards :: TextDocumentIdentifier -> Session () @@ -264,7 +264,7 @@ executeCmd cmd = do pure () evalLenses :: FilePath -> IO [CodeLens] -evalLenses path = runSessionWithServer evalPlugin testDataDir $ do +evalLenses path = runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc path "haskell" executeLensesBackwards doc getCodeLenses doc @@ -298,12 +298,10 @@ exceptionConfig exCfg = changeConfig ["exception" .= exCfg] goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree goldenWithEvalConfig' title path ext expected cfg = - goldenWithHaskellDoc evalPlugin title testDataDir path expected ext $ \doc -> do - sendConfigurationChanged (toJSON cfg) - executeLensesBackwards doc + goldenWithHaskellDoc cfg evalPlugin title testDataDir path expected ext executeLensesBackwards evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () -evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do +evalInFile fp e expected = runSessionWithServer def evalPlugin testDataDir $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs index 344f1552026..61235c5fbe6 100644 --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -51,7 +51,7 @@ hoverTestImport :: TestName -> Position -> T.Text -> TestTree hoverTestImport = hoverTest' "HoverImport.hs" hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree -hoverTest' docName title pos expected = testCase title $ runSessionWithServer plugin testDataDir $ do +hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc docName "haskell" waitForKickDone h <- getHover doc pos diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 2a45d16656e..9cc1fb482b5 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -42,12 +42,12 @@ main = defaultTestRunner $ testGroup "import-actions" , codeActionBreakFile "ExplicitBreakFile" 4 0 , codeActionStaleAction "ExplicitStaleAction" 4 0 , testCase "No CodeAction when exported" $ - runSessionWithServer explicitImportsPlugin testDataDir $ do + runSessionWithServer def explicitImportsPlugin testDataDir $ do doc <- openDoc "ExplicitExported.hs" "haskell" action <- getCodeActions doc (pointRange 3 0) liftIO $ action @?= [] , testCase "No CodeLens when exported" $ - runSessionWithServer explicitImportsPlugin testDataDir $ do + runSessionWithServer def explicitImportsPlugin testDataDir $ do doc <- openDoc "ExplicitExported.hs" "haskell" lenses <- getCodeLenses doc liftIO $ lenses @?= [] @@ -106,7 +106,7 @@ codeActionStaleAction fp l c = goldenWithImportActions " code action" fp codeAct case find ((== Just "Make this import explicit") . caTitle) actions of Just (InR x) -> maybeResolveCodeAction x >>= - \case Just _ -> liftIO $ assertFailure "Code action still valid" + \case Just _ -> liftIO $ assertFailure "Code action still valid" Nothing -> pure () _ -> liftIO $ assertFailure "Unable to find CodeAction" where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0) @@ -169,7 +169,7 @@ executeCmd cmd = do -- helpers goldenWithImportActions :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithImportActions title fp caps = goldenWithHaskellAndCaps caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs" +goldenWithImportActions title fp caps = goldenWithHaskellAndCaps def caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs" testDataDir :: String testDataDir = "test" "testdata" diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index abbf3d88090..b0cc6e8aab4 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -36,14 +36,14 @@ test = testGroup "explicit-fields" mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree mkTestNoAction title fp x1 y1 x2 y2 = testCase title $ - runSessionWithServer plugin (testDataDir "noop") $ do + runSessionWithServer def plugin (testDataDir "noop") $ do doc <- openDoc (fp <.> "hs") "haskell" actions <- getExplicitFieldsActions doc x1 y1 x2 y2 liftIO $ actions @?= [] mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree mkTest title fp x1 y1 x2 y2 = - goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do + goldenWithHaskellDoc def plugin title testDataDir fp "expected" "hs" $ \doc -> do (act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 executeCodeAction act diff --git a/plugins/hls-floskell-plugin/test/Main.hs b/plugins/hls-floskell-plugin/test/Main.hs index 908139f377f..baf55132873 100644 --- a/plugins/hls-floskell-plugin/test/Main.hs +++ b/plugins/hls-floskell-plugin/test/Main.hs @@ -24,7 +24,7 @@ tests = testGroup "floskell" ] goldenWithFloskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithFloskell title path desc = goldenWithHaskellDocFormatter floskellPlugin "floskell" def title testDataDir path desc "hs" +goldenWithFloskell title path desc = goldenWithHaskellDocFormatter def floskellPlugin "floskell" def title testDataDir path desc "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-fourmolu-plugin/test/Main.hs b/plugins/hls-fourmolu-plugin/test/Main.hs index 20506aefb6f..875720c8263 100644 --- a/plugins/hls-fourmolu-plugin/test/Main.hs +++ b/plugins/hls-fourmolu-plugin/test/Main.hs @@ -31,7 +31,7 @@ tests = ] goldenWithFourmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithFourmolu cli title path desc = goldenWithHaskellDocFormatter fourmoluPlugin "fourmolu" conf title testDataDir path desc "hs" +goldenWithFourmolu cli title path desc = goldenWithHaskellDocFormatter def fourmoluPlugin "fourmolu" conf title testDataDir path desc "hs" where conf = def{plcConfig = (\(Object obj) -> obj) $ object ["external" .= cli]} diff --git a/plugins/hls-gadt-plugin/test/Main.hs b/plugins/hls-gadt-plugin/test/Main.hs index a84a8fe991f..e92296eb0d0 100644 --- a/plugins/hls-gadt-plugin/test/Main.hs +++ b/plugins/hls-gadt-plugin/test/Main.hs @@ -48,7 +48,7 @@ tests = testGroup "GADT" gadtPragmaTest :: TestName -> Bool -> TestTree gadtPragmaTest title hasGADT = testCase title $ withCanonicalTempDir - $ \dir -> runSessionWithServer gadtPlugin dir $ do + $ \dir -> runSessionWithServer def gadtPlugin dir $ do doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"]) _ <- waitForProgressDone (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1)) @@ -61,7 +61,7 @@ gadtPragmaTest title hasGADT = testCase title runTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree runTest title fp x1 y1 x2 y2 = - goldenWithHaskellDoc gadtPlugin title testDataDir fp "expected" "hs" $ \doc -> do + goldenWithHaskellDoc def gadtPlugin title testDataDir fp "expected" "hs" $ \doc -> do _ <- waitForProgressDone (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position x1 y1) (Position x2 y2)) executeCodeAction act diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 9fca15bfb18..9da2aef8333 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -121,7 +121,7 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps hlintPlugin noLiteralCaps "test/testdata" $ do + , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps "test/testdata" $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" @@ -303,6 +303,7 @@ configTests :: TestTree configTests = testGroup "hlint plugin config" [ testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + setIgnoringConfigurationRequests False enableHlint doc <- openDoc "Base.hs" "haskell" @@ -315,19 +316,21 @@ configTests = testGroup "hlint plugin config" [ liftIO $ noHlintDiagnostics diags' , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do + setIgnoringConfigurationRequests False enableHlint doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"] - sendConfigurationChanged (toJSON config') + setHlsConfig config' diags' <- waitForDiagnosticsFrom doc liftIO $ noHlintDiagnostics diags' , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do + setIgnoringConfigurationRequests False enableHlint doc <- openDoc "Generalise.hs" "haskell" @@ -335,7 +338,7 @@ configTests = testGroup "hlint plugin config" [ expectNoMoreDiagnostics 3 doc "hlint" let config' = hlintConfigWithFlags ["--with-group=generalise"] - sendConfigurationChanged (toJSON config') + setHlsConfig config' diags' <- waitForDiagnosticsFromSource doc "hlint" d <- liftIO $ inspectDiagnostic diags' ["Use <>"] @@ -350,8 +353,7 @@ testDir :: FilePath testDir = "test/testdata" runHlintSession :: FilePath -> Session a -> IO a -runHlintSession subdir = - failIfSessionTimeout . runSessionWithServerAndCaps hlintPlugin codeActionNoResolveCaps (testDir subdir) +runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir subdir) noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -373,10 +375,10 @@ hlintConfigWithFlags flags = unObject _ = undefined enableHlint :: Session () -enableHlint = sendConfigurationChanged $ toJSON $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = True }) ] } +enableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = True }) ] } disableHlint :: Session () -disableHlint = sendConfigurationChanged $ toJSON $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = False }) ] } +disableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = False }) ] } -- We have two main code paths in the plugin depending on how hlint interacts with ghc: -- * One when hlint uses ghc-lib (all ghc versions but the last version supported by hlint) @@ -439,7 +441,7 @@ goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellAndCaps codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -460,4 +462,4 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithHaskellAndCaps codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" diff --git a/plugins/hls-module-name-plugin/test/Main.hs b/plugins/hls-module-name-plugin/test/Main.hs index 3ad306adc02..ae5a87f0d5c 100644 --- a/plugins/hls-module-name-plugin/test/Main.hs +++ b/plugins/hls-module-name-plugin/test/Main.hs @@ -38,7 +38,7 @@ tests = executeCommand c void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , testCase "Should not show code lens if the module name is correct" $ - runSessionWithServer moduleNamePlugin testDataDir $ do + runSessionWithServer def moduleNamePlugin testDataDir $ do doc <- openDoc "CorrectName.hs" "haskell" lenses <- getCodeLenses doc liftIO $ lenses @?= [] @@ -49,7 +49,7 @@ tests = executeCommand c void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , testCase "Keep stale lens even if parse failed" $ do - runSessionWithServer moduleNamePlugin testDataDir $ do + runSessionWithServer def moduleNamePlugin testDataDir $ do doc <- openDoc "Stale.hs" "haskell" oldLens <- getCodeLenses doc let edit = TextEdit (mkRange 1 0 1 0) "f =" @@ -61,7 +61,7 @@ tests = ] goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithModuleName title path = goldenWithHaskellDoc moduleNamePlugin title testDataDir path "expected" "hs" +goldenWithModuleName title path = goldenWithHaskellDoc def moduleNamePlugin title testDataDir path "expected" "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-ormolu-plugin/test/Main.hs b/plugins/hls-ormolu-plugin/test/Main.hs index 8b2e2f77a86..f0722ab3aca 100644 --- a/plugins/hls-ormolu-plugin/test/Main.hs +++ b/plugins/hls-ormolu-plugin/test/Main.hs @@ -29,7 +29,7 @@ tests = testGroup "ormolu" ] goldenWithOrmolu :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithOrmolu title path desc = goldenWithHaskellDocFormatter ormoluPlugin "ormolu" def title testDataDir path desc "hs" +goldenWithOrmolu title path desc = goldenWithHaskellDocFormatter def ormoluPlugin "ormolu" def title testDataDir path desc "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs index f76d8b8843a..e896951b67d 100644 --- a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs +++ b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs @@ -36,13 +36,13 @@ mkTest title fp selectorName x1 y1 x2 y2 = mkNoResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree mkNoResolveTest title fp selectorName x1 y1 x2 y2 = - goldenWithHaskellAndCaps codeActionNoResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + goldenWithHaskellAndCaps def codeActionNoResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do (act:_) <- getExplicitFieldsActions doc selectorName x1 y1 x2 y2 executeCodeAction act mkResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree mkResolveTest title fp selectorName x1 y1 x2 y2 = - goldenWithHaskellAndCaps codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do (act:_) <- getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 executeCodeAction act diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index 3a0260eb1ad..8eab91a91e2 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -178,7 +178,7 @@ mkEdit (startLine, startCol) (endLine, endCol) newText = completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail [delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol] = - testCase testComment $ runSessionWithServer pragmasCompletionPlugin testDataDir $ do + testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do doc <- openDoc fileName "haskell" _ <- waitForDiagnostics let te = TextEdit (Range (Position delFromLine delFromCol) (Position delToLine delToCol)) replacementText @@ -198,10 +198,10 @@ provideNoCompletionsTest testComment fileName mTextEdit pos = provideNoUndesiredCompletionsTest :: String -> FilePath -> Maybe T.Text -> Maybe TextEdit -> Position -> TestTree provideNoUndesiredCompletionsTest testComment fileName mUndesiredLabel mTextEdit pos = - testCase testComment $ runSessionWithServer pragmasCompletionPlugin testDataDir $ do + testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do + setConfigSection "haskell" disableGhcideCompletions doc <- openDoc fileName "haskell" _ <- waitForDiagnostics - _ <- sendConfigurationChanged disableGhcideCompletions mapM_ (applyEdit doc) mTextEdit compls <- getCompletions doc pos liftIO $ case mUndesiredLabel of @@ -214,10 +214,10 @@ provideNoUndesiredCompletionsTest testComment fileName mUndesiredLabel mTextEdit Nothing -> pure () disableGhcideCompletions :: Value -disableGhcideCompletions = object [ "haskell" .= object ["plugin" .= object [ "ghcide-completions" .= object ["globalOn" .= False]]] ] +disableGhcideCompletions = object [ "plugin" .= object [ "ghcide-completions" .= object ["globalOn" .= False]]] goldenWithPragmas :: PluginTestDescriptor () -> TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithPragmas descriptor title path = goldenWithHaskellDoc descriptor title testDataDir path "expected" "hs" +goldenWithPragmas descriptor title path = goldenWithHaskellDoc def descriptor title testDataDir path "expected" "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-qualify-imported-names-plugin/test/Main.hs b/plugins/hls-qualify-imported-names-plugin/test/Main.hs index 38409c218e0..9ea46b210c3 100644 --- a/plugins/hls-qualify-imported-names-plugin/test/Main.hs +++ b/plugins/hls-qualify-imported-names-plugin/test/Main.hs @@ -21,7 +21,7 @@ import Test.Hls (CodeAction (CodeAction, _title TestName, TestTree, TextDocumentIdentifier, assertBool, assertFailure, - defaultTestRunner, + def, defaultTestRunner, executeCodeAction, getCodeActions, goldenWithHaskellDoc, @@ -61,13 +61,13 @@ main :: IO () main = defaultTestRunner $ testGroup "Qualify Imported Names" [ testCase "No CodeAction when not at import" $ - runSessionWithServer pluginDescriptor testDataDir $ do + runSessionWithServer def pluginDescriptor testDataDir $ do let point = makePoint 1 1 document <- openDoc "NoImport.hs" "haskell" actions <- getCodeActions document $ pointToRange point liftIO $ assertBool (makeCodeActionFoundAtString point) (isEmpty actions) , testCase "No CodeAction when import is qualified" $ - runSessionWithServer pluginDescriptor testDataDir $ do + runSessionWithServer def pluginDescriptor testDataDir $ do let point = makePoint 3 1 document <- openDoc "QualifiedImport.hs" "haskell" actions <- getCodeActions document $ pointToRange point @@ -139,7 +139,7 @@ getCodeActionTitle commandOrCodeAction goldenWithQualifyImportedNames :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithQualifyImportedNames testName path = - goldenWithHaskellDoc pluginDescriptor testName testDataDir path "expected" "hs" + goldenWithHaskellDoc def pluginDescriptor testName testDataDir path "expected" "hs" pointToRange :: Point -> Range pointToRange Point {..} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index ce26d88fabe..7340215ead0 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -38,7 +38,6 @@ import Language.Haskell.GHC.ExactPrint (TransformT (..), noAnnSrcSpanDP1, runTransformT) import Language.Haskell.GHC.ExactPrint.Transform (d1) -import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types #endif diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index b7fac7ce763..ac7fe1a7cd5 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -273,7 +273,6 @@ completionCommandTest name src pos wanted expected = testSession name $ do executeCommand c if src /= expected then do - void $ skipManyTill anyMessage loggingNotification modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) liftIO $ modifiedCode @?= T.unlines expected else do diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs index 8f34798bf63..0d16e5be194 100644 --- a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -64,6 +64,7 @@ mkGoldenAddArgTest' testFileName range varName = do liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function") executeCodeAction action goldenWithHaskellDoc + def (mkPluginTestDescriptor Refactor.bindingsPluginDescriptor "ghcide-code-actions-bindings") (testFileName <> " (golden)") "test/data/golden/add-arg" diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 6acafd9cecd..e9cfd83c8d5 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -69,11 +69,7 @@ tests = testGroup "Rename" goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithRename title path act = - goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" $ \doc -> do - sendConfigurationChanged $ toJSON $ - def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] } - act doc - + goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-retrie-plugin/test/Main.hs b/plugins/hls-retrie-plugin/test/Main.hs index ef17fceb58d..5f8d12658a1 100644 --- a/plugins/hls-retrie-plugin/test/Main.hs +++ b/plugins/hls-retrie-plugin/test/Main.hs @@ -80,13 +80,10 @@ codeActionTitle _ = Nothing goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithRetrie title path act = - goldenWithHaskellDoc testPlugins title testDataDir path "expected" "hs" $ \doc -> do - sendConfigurationChanged $ toJSON $ - def { plugins = M.fromList [("retrie", def)] } - act doc + goldenWithHaskellDoc (def { plugins = M.fromList [("retrie", def)] }) testPlugins title testDataDir path "expected" "hs" act runWithRetrie :: Session a -> IO a -runWithRetrie = runSessionWithServer testPlugins testDataDir +runWithRetrie = runSessionWithServer def testPlugins testDataDir testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log testPlugins = diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 8a2800305e4..4f57273d8e3 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -69,7 +69,7 @@ tests = testGroup "splice" goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree goldenTest fp tc line col = - goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do + goldenWithHaskellDoc def splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do -- wait for the entire build to finish, so that code actions that -- use stale data will get uptodate stuff void waitForBuildQueue @@ -82,7 +82,7 @@ goldenTest fp tc line col = goldenTestWithEdit :: FilePath -> FilePath -> ExpandStyle -> Int -> Int -> TestTree goldenTestWithEdit fp expect tc line col = - goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp expect "hs" $ \doc -> do + goldenWithHaskellDoc def splicePlugin (fp <> " (golden)") testDataDir fp expect "hs" $ \doc -> do orig <- documentContents doc let lns = T.lines orig diff --git a/plugins/hls-stylish-haskell-plugin/test/Main.hs b/plugins/hls-stylish-haskell-plugin/test/Main.hs index bd6f55e9e66..9dadebf5980 100644 --- a/plugins/hls-stylish-haskell-plugin/test/Main.hs +++ b/plugins/hls-stylish-haskell-plugin/test/Main.hs @@ -22,7 +22,7 @@ tests = testGroup "stylish-haskell" ] goldenWithStylishHaskell :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithStylishHaskell title fp desc = goldenWithHaskellDocFormatter stylishHaskellPlugin "stylishHaskell" def title testDataDir fp desc "hs" +goldenWithStylishHaskell title fp desc = goldenWithHaskellDocFormatter def stylishHaskellPlugin "stylishHaskell" def title testDataDir fp desc "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-tactics-plugin/new/test/Utils.hs b/plugins/hls-tactics-plugin/new/test/Utils.hs index 85a15bb4366..f634347441e 100644 --- a/plugins/hls-tactics-plugin/new/test/Utils.hs +++ b/plugins/hls-tactics-plugin/new/test/Utils.hs @@ -65,7 +65,7 @@ runSessionForTactics = runSessionWithServer' (IdePlugins [plugin]) def - (def { messageTimeout = 20 } ) + (def { messageTimeout = 20, ignoreLogNotifications = False } ) fullCaps tacticPath diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index cc41f4bac32..33fcc274766 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -4,11 +4,14 @@ module Completion(tests) where import Control.Lens hiding ((.=)) -import Data.Aeson (object, (.=)) +import Data.Aeson (toJSON) +import Data.Aeson.KeyMap (singleton) import Data.Foldable (find) +import Data.Functor (void) +import qualified Data.Map as Map import Data.Row.Records (focus) import qualified Data.Text as T -import Ide.Plugin.Config (maxCompletions) +import Ide.Plugin.Config (maxCompletions, plcConfig, plugins) import Language.LSP.Protocol.Lens hiding (applyEdit, length) import Test.Hls import Test.Hls.Command @@ -282,12 +285,13 @@ snippetTests = testGroup "snippets" [ item ^. insertTextFormat @?= Just InsertTextFormat_PlainText item ^. insertText @?= Nothing - , testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + , testCase "respects lsp configuration" $ runSessionWithConfig (def {ignoreConfigurationRequests=False}) hlsCommand fullCaps "test/testdata/completion" $ do + void configurationRequest doc <- openDoc "Completion.hs" "haskell" - let config = object ["haskell" .= object ["plugin" .= object ["ghcide-completions" .= object ["config" .= object ["snippetsOn" .= False]]]]] + let config = def { plugins = Map.insert "ghcide-completions" (def { plcConfig = singleton "snippetsOn" (toJSON False)}) (plugins def) } - sendConfigurationChanged config + setHlsConfig config checkNoSnippets doc diff --git a/test/functional/Config.hs b/test/functional/Config.hs index f2e1a4d3763..a474051808c 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -7,7 +7,6 @@ module Config (tests) where import Control.DeepSeq import Control.Monad -import Data.Aeson import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.Map as Map @@ -43,26 +42,26 @@ genericConfigTests = testGroup "generic plugin config" , testCase "custom defaults and user config on some other plugin" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config doesn't accidentally override the initial config - sendConfigurationChanged $ toJSON (changeConfig "someplugin" def{plcHoverOn = False}) + setHlsConfig $ changeConfig "someplugin" def{plcHoverOn = False} -- getting only the expected diagnostics means the plugin wasn't enabled expectDiagnostics standardDiagnostics , expectFailBecause "partial config is not supported" $ testCase "custom defaults and non overlapping user config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config doesn't accidentally override the initial config - sendConfigurationChanged $ toJSON (changeConfig testPluginId def{plcHoverOn = False}) + setHlsConfig $ changeConfig testPluginId def{plcHoverOn = False} -- getting only the expected diagnostics means the plugin wasn't enabled expectDiagnostics standardDiagnostics , testCase "custom defaults and overlapping user plugin config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config overrides the default initial config - sendConfigurationChanged $ toJSON (changeConfig testPluginId def{plcGlobalOn = True}) + setHlsConfig $ changeConfig testPluginId def{plcGlobalOn = True} -- getting only the expected diagnostics means the plugin wasn't enabled expectDiagnostics testPluginDiagnostics , testCase "custom defaults and non plugin user config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config doesn't accidentally override the initial config - sendConfigurationChanged $ toJSON (def {formattingProvider = "foo"}) + setHlsConfig $ def {formattingProvider = "foo"} -- getting only the expected diagnostics means the plugin wasn't enabled expectDiagnostics standardDiagnostics ] @@ -70,12 +69,13 @@ genericConfigTests = testGroup "generic plugin config" standardDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Warning, (1,0), "Top-level binding")])] testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] - runConfigSession subdir = - failIfSessionTimeout . runSessionWithServer @() plugin ("test/testdata" subdir) + runConfigSession subdir session = do + recorder <- pluginTestRecorder + failIfSessionTimeout $ runSessionWithServer' @() (plugin recorder) def (def {ignoreConfigurationRequests=False}) fullCaps ("test/testdata" subdir) session testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics - plugin = mkPluginTestDescriptor' pd testPluginId + plugin = mkPluginTestDescriptor' @() pd testPluginId pd plId = (defaultPluginDescriptor plId) { pluginConfigDescriptor = configDisabled @@ -95,7 +95,7 @@ genericConfigTests = testGroup "generic plugin config" } changeConfig :: PluginId -> PluginConfig -> Config changeConfig plugin conf = - def{plugins = Map.fromList [(plugin, conf)]} + def{plugins = Map.insert plugin conf (plugins def)} data GetTestDiagnostics = GetTestDiagnostics diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index d4eeb70e000..eb8d1aa72da 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -106,7 +106,7 @@ tests = testGroup "deferred responses" [ -- cwd <- liftIO getCurrentDirectory -- let testUri = filePathToUri $ cwd "test/testdata/FuncTest.hs" - -- diags <- skipManyTill loggingNotification publishDiagnosticsNotification + -- diags <- publishDiagnosticsNotification -- liftIO $ diags ^? params @?= (Just $ PublishDiagnosticsParams -- { _uri = testUri -- , _diagnostics = List diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 42410d2068f..2f018c3d3c9 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -4,11 +4,12 @@ module Format (tests) where import Control.Lens ((^.)) import Control.Monad.IO.Class -import Data.Aeson import qualified Data.ByteString.Lazy as BS +import Data.Functor (void) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T +import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Test @@ -46,6 +47,7 @@ rangeTests = requiresOrmoluPlugin $ testGroup "format range" [ providerTests :: TestTree providerTests = testGroup "formatting provider" [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do + void configurationRequest doc <- openDoc "Format.hs" "haskell" resp <- request SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) liftIO $ case resp ^. L.result of @@ -55,45 +57,29 @@ providerTests = testGroup "formatting provider" [ _ -> assertFailure $ "strange response from formatting provider:" ++ show result result -> assertFailure $ "strange response from formatting provider:" ++ show result - , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do + void configurationRequest formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" formattedOrmoluPostFloskell <- liftIO $ T.readFile "test/testdata/format/Format.ormolu_post_floskell.formatted.hs" doc <- openDoc "Format.hs" "haskell" - sendConfigurationChanged (formatLspConfig "ormolu") + setHlsConfig (formatLspConfig "ormolu") formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedOrmolu) - sendConfigurationChanged (formatLspConfig "floskell") + setHlsConfig (formatLspConfig "floskell") formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedFloskell) - sendConfigurationChanged (formatLspConfig "ormolu") + setHlsConfig (formatLspConfig "ormolu") formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedOrmoluPostFloskell) - , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" - formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" - - doc <- openDoc "Format.hs" "haskell" - - sendConfigurationChanged (formatLspConfigOld "ormolu") - formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) - documentContents doc >>= liftIO . (@?= formattedOrmolu) - - sendConfigurationChanged (formatLspConfigOld "floskell") - formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) - documentContents doc >>= liftIO . (@?= formattedFloskell) ] -formatLspConfig :: Value -> Value -formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] - --- | The same as 'formatLspConfig' but using the legacy section name -formatLspConfigOld :: Value -> Value -formatLspConfigOld provider = object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] +formatLspConfig :: T.Text -> Config +formatLspConfig provider = def { formattingProvider = provider } -formatConfig :: Value -> SessionConfig -formatConfig provider = defaultConfig { lspConfig = Just (formatLspConfig provider) } +formatConfig :: T.Text -> SessionConfig +formatConfig provider = defaultConfig { lspConfig = hlsConfigToClientConfig (formatLspConfig provider), ignoreConfigurationRequests = False } diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 31215300902..f82c5787c4e 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -6,7 +6,6 @@ module FunctionalCodeAction (tests) where import Control.Lens hiding (List) import Control.Monad -import Data.Aeson import Data.Aeson.Lens (_Object) import Data.List import qualified Data.Map as M @@ -48,7 +47,7 @@ renameTests = testGroup "rename suggestions" [ cars <- getAllCodeActions doc replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] executeCommand replaceButStrLn - _ <- skipManyTill loggingNotification anyRequest + _ <- anyRequest x:_ <- T.lines <$> documentContents doc liftIO $ x @?= "main = putStrLn \"hello\"" @@ -71,7 +70,7 @@ renameTests = testGroup "rename suggestions" [ _ -> error $ "Unexpected arguments: " ++ show mbArgs executeCommand cmd - _ <- skipManyTill loggingNotification anyRequest + _ <- anyRequest x1:x2:_ <- T.lines <$> documentContents doc liftIO $ @@ -82,11 +81,8 @@ renameTests = testGroup "rename suggestions" [ importTests :: TestTree importTests = testGroup "import suggestions" [ - testCase "import works with 3.8 code action kinds" $ runSession hlsCommand fullCaps "test/testdata" $ do + testCase "import works with 3.8 code action kinds" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImport.hs" "haskell" - -- No Formatting: - let config = def { formattingProvider = "none" } - sendConfigurationChanged (toJSON config) (diag:_) <- waitForDiagnosticsFrom doc liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" @@ -107,12 +103,8 @@ importTests = testGroup "import suggestions" [ importQualifiedTests :: TestTree importQualifiedTests = testGroup "import qualified prefix suggestions" [ - testCase "qualified import works with 3.8 code action kinds" $ runSession hlsCommand fullCaps "test/testdata" $ do + testCase "qualified import works with 3.8 code action kinds" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImportQualified.hs" "haskell" - -- No Formatting: - let config = def { formattingProvider = "none" } - sendConfigurationChanged (toJSON config) - (diag:_) <- waitForDiagnosticsFrom doc liftIO $ diag ^. L.message @?= if ghcVersion >= GHC96 @@ -136,12 +128,8 @@ importQualifiedTests = testGroup "import qualified prefix suggestions" [ importQualifiedPostTests :: TestTree importQualifiedPostTests = testGroup "import qualified postfix suggestions" [ - testCase "qualified import in postfix position works with 3.8 code action kinds" $ runSession hlsCommand fullCaps "test/testdata" $ do + testCase "qualified import in postfix position works with 3.8 code action kinds" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImportPostQualified.hs" "haskell" - -- No Formatting: - let config = def { formattingProvider = "none" } - sendConfigurationChanged (toJSON config) - (diag:_) <- waitForDiagnosticsFrom doc liftIO $ diag ^. L.message @?= if ghcVersion >= GHC96 @@ -285,7 +273,7 @@ redundantImportTests = testGroup "redundant import code actions" [ cas <- getAllCodeActions doc cmd <- liftIO $ inspectCommand cas ["redundant import"] executeCommand cmd - _ <- skipManyTill loggingNotification anyRequest + _ <- anyRequest contents <- documentContents doc liftIO $ T.lines contents @?= [ "{-# OPTIONS_GHC -Wunused-imports #-}" @@ -300,8 +288,7 @@ redundantImportTests = testGroup "redundant import code actions" [ typedHoleTests :: TestTree typedHoleTests = testGroup "typed hole code actions" [ testCase "works" $ - runSession hlsCommand fullCaps "test/testdata" $ do - disableWingman + runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles.hs" "haskell" _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) cas <- getAllCodeActions doc @@ -331,8 +318,7 @@ typedHoleTests = testGroup "typed hole code actions" [ dontExpectCodeAction cas ["replace _ with foo _"] , testCase "shows more suggestions" $ - runSession hlsCommand fullCaps "test/testdata" $ do - disableWingman + runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles2.hs" "haskell" _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) cas <- getAllCodeActions doc @@ -444,8 +430,10 @@ unusedTermTests = testGroup "unused term code actions" [ $ Just CodeActionKind_QuickFix `notElem` kinds ] -disableWingman :: Session () -disableWingman = - sendConfigurationChanged $ toJSON $ def - { plugins = M.fromList [ ("tactics", def { plcGlobalOn = False }) ] - } +testConfig :: Config +testConfig = def { + formattingProvider = "none" + , plugins = M.insert "tactics" (def { plcGlobalOn = False }) (plugins def) + } + + diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 62d90e33146..6791eb223b1 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -10,11 +10,12 @@ module Progress (tests) where import Control.Exception (throw) import Control.Lens hiding ((.=)) -import Data.Aeson (Value, decode, encode, - object, (.=)) +import Data.Aeson (decode, encode) +import Data.Functor (void) import Data.List (delete) import Data.Maybe (fromJust) import Data.Text (Text, pack) +import Ide.Types import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as L import System.FilePath (()) @@ -57,23 +58,25 @@ tests = expectProgressMessages ["Evaluating"] activeProgressTokens _ -> error $ "Unexpected response result: " ++ show response , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do - runSession hlsCommand progressCaps "test/testdata/format" $ do - sendConfigurationChanged (formatLspConfig "ormolu") + runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsCommand progressCaps "test/testdata/format" $ do + void configurationRequest + setHlsConfig (formatLspConfig "ormolu") doc <- openDoc "Format.hs" "haskell" expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressMessages ["Formatting Format.hs"] [] , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do - runSession hlsCommand progressCaps "test/testdata/format" $ do - sendConfigurationChanged (formatLspConfig "fourmolu") + runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsCommand progressCaps "test/testdata/format" $ do + void configurationRequest + setHlsConfig (formatLspConfig "fourmolu") doc <- openDoc "Format.hs" "haskell" expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressMessages ["Formatting Format.hs"] [] ] -formatLspConfig :: Value -> Value -formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= (provider :: Value)]] +formatLspConfig :: Text -> Config +formatLspConfig provider = def { formattingProvider = provider } progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)}