diff --git a/cabal.project b/cabal.project index 2c6896c504..faa94671f8 100644 --- a/cabal.project +++ b/cabal.project @@ -7,7 +7,7 @@ packages: ./hls-plugin-api ./hls-test-utils -index-state: 2024-05-10T00:00:00Z +index-state: 2024-06-07T00:00:00Z tests: True test-show-details: direct diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index d4b7f8f9fb..3b80f37c49 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -48,9 +48,9 @@ import Ide.Logger (Doc, Pretty (pretty), import Ide.Plugin.Config (Config) import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Protocol.Message (Method (Method_Initialize), - ResponseError, SMethod (SMethod_Exit, SMethod_WindowShowMessageRequest), - TRequestMessage) + TRequestMessage, + TResponseError) import Language.LSP.Protocol.Types (MessageActionItem (MessageActionItem), MessageType (MessageType_Error), ShowMessageRequestParams (ShowMessageRequestParams), @@ -283,7 +283,7 @@ launchErrorLSP recorder errorMsg = do -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () - let doInitialize :: LSP.LanguageContextEnv Config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ())) + let doInitialize :: LSP.LanguageContextEnv Config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv Config, ())) doInitialize env _ = do let restartTitle = "Try to restart" diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index b9e8d1500b..525f07a37d 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -557,7 +557,7 @@ runBenchmarksFun dir allBenchmarks = do ] ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] lspTestCaps = - fullCaps + fullLatestClientCaps & (L.window . _Just) .~ WindowClientCapabilities (Just True) Nothing Nothing & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (ClientCodeActionResolveOptions ["edit"]) & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True @@ -842,19 +842,19 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do not . null <$> getCompletions doc pos -getBuildKeysBuilt :: Session (Either ResponseError [T.Text]) +getBuildKeysBuilt :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text]) getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt -getBuildKeysVisited :: Session (Either ResponseError [T.Text]) +getBuildKeysVisited :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text]) getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited -getBuildKeysChanged :: Session (Either ResponseError [T.Text]) +getBuildKeysChanged :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text]) getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged -getBuildEdgesCount :: Session (Either ResponseError Int) +getBuildEdgesCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int) getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount -getRebuildsCount :: Session (Either ResponseError Int) +getRebuildsCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int) getRebuildsCount = tryCallTestPlugin GetRebuildsCount -- Copy&paste from ghcide/test/Development.IDE.Test @@ -862,7 +862,7 @@ getStoredKeys :: Session [Text] getStoredKeys = callTestPlugin GetStoredKeys -- Copy&paste from ghcide/test/Development.IDE.Test -tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b) tryCallTestPlugin cmd = do let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) @@ -878,5 +878,5 @@ callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b callTestPlugin cmd = do res <- tryCallTestPlugin cmd case res of - Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err - Right a -> pure a + Left (TResponseError t err _) -> error $ show t <> ": " <> T.unpack err + Right a -> pure a diff --git a/ghcide-bench/test/Main.hs b/ghcide-bench/test/Main.hs index 37fee52d79..a58016ab2b 100644 --- a/ghcide-bench/test/Main.hs +++ b/ghcide-bench/test/Main.hs @@ -41,7 +41,7 @@ benchmarkTests = ] runInDir :: FilePath -> Session a -> IO a -runInDir dir = runSessionWithConfig defaultConfig cmd fullCaps dir +runInDir dir = runSessionWithConfig defaultConfig cmd fullLatestClientCaps dir where -- TODO use HLS instead of ghcide cmd = "ghcide --lsp --test --verbose -j2 --cwd " <> dir diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 948dfeb034..d9c4c1ae53 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -88,8 +88,8 @@ library , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , list-t - , lsp ^>=2.6.0.0 - , lsp-types ^>=2.2.0.0 + , lsp ^>=2.7 + , lsp-types ^>=2.3 , mtl , opentelemetry >=0.6.1 , optparse-applicative diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 58c1f49d0b..3c7984b8e8 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -90,7 +90,7 @@ runLanguageServer -> (config -> Value -> Either T.Text config) -> (config -> m config ()) -> (MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), + -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () @@ -217,22 +217,24 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c exceptionInHandler e = do logWith recorder Error $ LogReactorMessageActionException e + checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO () checkCancelled _id act k = - flip finally (clearReqId _id) $ + let sid = SomeLspId _id + in flip finally (clearReqId sid) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act + cancelOrRes <- race (waitForCancel sid) act case cancelOrRes of Left () -> do - logWith recorder Debug $ LogCancelledRequest _id - k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing + logWith recorder Debug $ LogCancelledRequest sid + k $ TResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing + k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do putMVar dbMVar (WithHieDbShield withHieDb',hieChan') diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index f4a52adcb3..e2b234557d 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -22,7 +22,7 @@ import UnliftIO.Chan data ReactorMessage = ReactorNotification (IO ()) - | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) + | forall m . ReactorRequest (LspId m) (IO ()) (TResponseError m -> IO ()) type ReactorChan = Chan ReactorMessage newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a } @@ -31,17 +31,17 @@ newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (Ls requestHandler :: forall m c. PluginMethod Request m => SMethod m - -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) + -> (IdeState -> MessageParams m -> LspM c (Either (TResponseError m) (MessageResult m))) -> Handlers (ServerM c) requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' :: Either ResponseError (MessageResult m) -> LspM c () + let resp' :: Either (TResponseError m) (MessageResult m) -> LspM c () resp' = flip (runReaderT . unServerM) st . resp trace x = otTracedHandler "Request" (show _method) $ \sp -> do traceWithSpan sp _params x - writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) + writeChan chan $ ReactorRequest (_id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler :: forall m c. PluginMethod Notification m => diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 3a30e05f99..3f1c19d1a2 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -54,7 +54,7 @@ import UnliftIO.Exception (catchAny) data Log = LogPluginError PluginId PluginError - | LogResponseError PluginId ResponseError + | forall m . A.ToJSON (ErrorData m) => LogResponseError PluginId (TResponseError m) | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException @@ -73,10 +73,10 @@ instance Pretty Log where <> pretty method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty -noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either ResponseError c) +noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c) noPluginHandles recorder m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing + let err = TResponseError (InR ErrorCodes_MethodNotFound) msg Nothing msg = noPluginHandlesMsg m fs' return $ Left err where noPluginHandlesMsg :: SMethod m -> [(PluginId, HandleRequestResult)] -> Text @@ -112,9 +112,9 @@ exceptionInPlugin plId method exception = "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception) -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError :: A.ToJSON (ErrorData m) => Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either (TResponseError m) a) logAndReturnError recorder p errCode msg = do - let err = ResponseError errCode msg Nothing + let err = TResponseError errCode msg Nothing logWith recorder Warning $ LogResponseError p err pure $ Left err @@ -176,7 +176,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom _ -> Nothing -- The parameters to the HLS command are always the first element - execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) + execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null)) execCmd ide (ExecuteCommandParams mtoken cmdId args) = do let cmdParams :: A.Value cmdParams = case args of @@ -196,8 +196,10 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- If we have a command, continue to execute it Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) + -- TODO: This should be a response error? Nothing -> return $ Right $ InR Null + -- TODO: This should be a response error? A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command @@ -206,9 +208,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- Couldn't parse the command identifier _ -> do logWith recorder Warning LogInvalidCommandIdentifier - return $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing + return $ Left $ TResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing - runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) + runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null)) runPluginCommand ide p com mtoken arg = case Map.lookup p pluginMap of Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p) @@ -314,13 +316,13 @@ runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedPro f a b -- See Note [Exception handling in plugins] `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError +combineErrors :: NonEmpty (PluginId, PluginError) -> TResponseError m combineErrors (x NE.:| []) = toResponseError x combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs -toResponseError :: (PluginId, PluginError) -> ResponseError +toResponseError :: (PluginId, PluginError) -> TResponseError m toResponseError (PluginId plId, err) = - ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing + TResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing where tPretty = T.pack . show . pretty logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index d77a8399be..cd58fd5ead 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -153,7 +153,7 @@ defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_t defToLocation (InR (InR Null)) = [] lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } +lspTestCaps = fullLatestClientCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } lspTestCapsNoFileWatches :: ClientCapabilities lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 6c08f7ecba..ad53c97bb3 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -56,7 +56,7 @@ tests = do doc <- createDoc "A.hs" "haskell" "module A where" (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) case lens of - Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + Left (TResponseError {_code = InR ErrorCodes_InternalError, _message}) -> liftIO $ assertBool "We caught an error, but it wasn't ours!" (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) _ -> liftIO $ assertFailure $ show lens @@ -80,7 +80,7 @@ tests = do execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments) (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams case res of - Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + Left (TResponseError {_code = InR ErrorCodes_InternalError, _message}) -> liftIO $ assertBool "We caught an error, but it wasn't ours!" (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) _ -> liftIO $ assertFailure $ show res diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a06b4764f4..a28467e634 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -259,8 +259,8 @@ library hls-cabal-plugin , hls-plugin-api == 2.8.0.0 , hls-graph == 2.8.0.0 , lens - , lsp ^>=2.6 - , lsp-types ^>=2.2 + , lsp ^>=2.7 + , lsp-types ^>=2.3 , regex-tdfa ^>=1.3.1 , text , text-rope @@ -390,7 +390,7 @@ library hls-call-hierarchy-plugin , hiedb ^>= 0.6.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.6 + , lsp >=2.7 , sqlite-simple , text @@ -1004,7 +1004,7 @@ library hls-alternate-number-format-plugin , hls-graph , hls-plugin-api == 2.8.0.0 , lens - , lsp ^>=2.6 + , lsp ^>=2.7 , mtl , regex-tdfa , syb @@ -1234,7 +1234,7 @@ library hls-gadt-plugin , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens - , lsp >=2.6 + , lsp >=2.7 , mtl , text , transformers @@ -1283,7 +1283,7 @@ library hls-explicit-fixity-plugin , ghcide == 2.8.0.0 , hashable , hls-plugin-api == 2.8.0.0 - , lsp >=2.6 + , lsp >=2.7 , text default-extensions: DataKinds @@ -1426,7 +1426,7 @@ library hls-floskell-plugin , floskell ^>=0.11.0 , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 - , lsp-types ^>=2.2 + , lsp-types ^>=2.3 , mtl , text @@ -1806,7 +1806,7 @@ library hls-notes-plugin , hls-graph == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.6 + , lsp >=2.7 , mtl >= 2.2 , regex-tdfa >= 1.3.1 , text @@ -2113,7 +2113,7 @@ test-suite ghcide-tests , lens , list-t , lsp - , lsp-test ^>=0.17.0.1 + , lsp-test ^>=0.17.1 , lsp-types , monoid-subclasses , mtl diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 8ab49c789f..201459d143 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -69,7 +69,7 @@ library , hls-graph == 2.8.0.0 , lens , lens-aeson - , lsp ^>=2.6 + , lsp ^>=2.7 , megaparsec >=9.0 , mtl , opentelemetry >=0.4 diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 0657d750ac..3a3638c12b 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -38,7 +38,7 @@ import Language.LSP.Server (LspT, getClientCapabilities, data Log = DoesNotSupportResolve T.Text - | ApplyWorkspaceEditFailed ResponseError + | forall m . A.ToJSON (ErrorData m) => ApplyWorkspaceEditFailed (TResponseError m) instance Pretty Log where pretty = \case DoesNotSupportResolve fallback-> diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 252eb51799..299d869b7b 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -48,7 +48,7 @@ library , lens , lsp , lsp-test ^>=0.17 - , lsp-types ^>=2.2 + , lsp-types ^>=2.3 , neat-interpolation , safe-exceptions , tasty diff --git a/hls-test-utils/src/Development/IDE/Test.hs b/hls-test-utils/src/Development/IDE/Test.hs index 30f951e903..285d91aadb 100644 --- a/hls-test-utils/src/Development/IDE/Test.hs +++ b/hls-test-utils/src/Development/IDE/Test.hs @@ -187,7 +187,7 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics -tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b) tryCallTestPlugin cmd = do let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) @@ -202,8 +202,8 @@ callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b callTestPlugin cmd = do res <- tryCallTestPlugin cmd case res of - Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err - Right a -> pure a + Left (TResponseError t err _) -> error $ show t <> ": " <> T.unpack err + Right a -> pure a waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 15f41e3b2b..479f1b04d6 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -537,7 +537,7 @@ instance Default (TestConfig b) where testPluginDescriptor = mempty, testLspConfig = def, testConfigSession = def, - testConfigCaps = fullCaps, + testConfigCaps = fullLatestClientCaps, testCheckProject = False } @@ -834,7 +834,7 @@ waitForBuildQueue = do -- assume a ghcide binary lacking the WaitForShakeQueue method _ -> return 0 -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b) callTestPlugin cmd = do let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) @@ -842,17 +842,17 @@ callTestPlugin cmd = do return $ do e <- _result case A.fromJSON e of - A.Error err -> Left $ ResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing + A.Error err -> Left $ TResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing A.Success a -> pure a -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction :: String -> TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) -waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool) +waitForTypecheck :: TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Bool) waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid -getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text]) getLastBuildKeys = callTestPlugin GetBuildKeysBuilt hlsConfigToClientConfig :: Config -> A.Object diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 64c976fd8e..eaba6c595b 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -99,12 +99,12 @@ codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps literalSupport = ClientCodeActionLiteralOptions (ClientCodeActionKindOptions []) codeActionResolveCaps :: ClientCapabilities -codeActionResolveCaps = Test.fullCaps +codeActionResolveCaps = Test.fullLatestClientCaps & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ ClientCodeActionResolveOptions {_properties= ["edit"]} & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True codeActionNoResolveCaps :: ClientCapabilities -codeActionNoResolveCaps = Test.fullCaps +codeActionNoResolveCaps = Test.fullLatestClientCaps & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False -- --------------------------------------------------------------------- diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index e10c45035b..88eac8eafd 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -43,7 +43,7 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi let res = resp ^. result pure $ fmap (showSelectionRangesForTest . absorbNull) res case res of - Left (ResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure "" + Left (TResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure "" Left err -> assertFailure (show err) Right golden -> pure golden where diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 2c599b5b6b..8c7154e912 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -63,7 +63,7 @@ importCommandId = "ImportLensCommand" data Log = LogShake Shake.Log - | LogWAEResponseError ResponseError + | LogWAEResponseError (TResponseError Method_WorkspaceApplyEdit) | forall a. (Pretty a) => LogResolve a @@ -109,7 +109,7 @@ runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do wedit <- resolveWTextEdit ideState eird _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors return $ InR Null - where logErrors (Left re@(ResponseError{})) = do + where logErrors (Left re) = do logWith recorder Error (LogWAEResponseError re) pure () logErrors (Right _) = pure () diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 7777eb5eec..a4e5b235d8 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3759,7 +3759,7 @@ runInDir dir act = $ const act lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } +lspTestCaps = fullLatestClientCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index e35d7c5b06..cd4d3f6f88 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} @@ -69,7 +70,7 @@ tests = testGroup "Rename" , goldenWithRename "Type variable" "TypeVariable" $ \doc -> rename doc (Position 0 13) "b" , goldenWithRename "Rename within comment" "Comment" $ \doc -> do - let expectedError = ResponseError + let expectedError = TResponseError (InR ErrorCodes_InvalidParams) "rename: Invalid Params: No symbol to rename at given position" Nothing @@ -119,7 +120,7 @@ goldenWithRename title path act = goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act -renameExpectError :: ResponseError -> TextDocumentIdentifier -> Position -> Text -> Session () +renameExpectError :: (TResponseError Method_TextDocumentRename) -> TextDocumentIdentifier -> Position -> Text -> Session () renameExpectError expectedError doc pos newName = do let params = RenameParams Nothing doc pos newName rsp <- request SMethod_TextDocumentRename params @@ -135,7 +136,7 @@ expectRenameError :: TextDocumentIdentifier -> Position -> String -> - Session ResponseError + Session (TResponseError Method_TextDocumentRename) expectRenameError doc pos newName = do let params = RenameParams Nothing doc pos (pack newName) rsp <- request SMethod_TextDocumentRename params diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 5308b6fd71..2f0fcc1b92 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -141,7 +141,7 @@ semanticTokensConfigTest = , testConfigSession = def { ignoreConfigurationRequests = False } - , testConfigCaps = fullCaps + , testConfigCaps = fullLatestClientCaps , testDirLocation = Right fs , testLspConfig = mkSemanticConfig funcVar } diff --git a/stack-lts21.yaml b/stack-lts21.yaml index 18a452c8c7..b807968454 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -23,9 +23,9 @@ extra-deps: - monad-dijkstra-0.1.1.3 - retrie-1.2.2 - stylish-haskell-0.14.4.0 -- lsp-2.6.0.0 -- lsp-test-0.17.0.2 -- lsp-types-2.2.0.0 +- lsp-2.7.0.0 +- lsp-test-0.17.1.0 +- lsp-types-2.3.0.0 # stan dependencies not found in the stackage snapshot - stan-0.1.2.0 diff --git a/stack.yaml b/stack.yaml index f494916ac2..13279c5fe4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,9 +20,9 @@ extra-deps: - hiedb-0.6.0.0 - hie-bios-0.14.0 - implicit-hie-0.1.4.0 -- lsp-2.6.0.0 -- lsp-test-0.17.0.2 -- lsp-types-2.2.0.0 +- lsp-2.7.0.0 +- lsp-test-0.17.1.0 +- lsp-types-2.3.0.0 - monad-dijkstra-0.1.1.4 # stan and friends diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 3c81529321..a8fe534e9d 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -23,18 +23,18 @@ tests = testGroup "format document" providerTests :: TestTree providerTests = testGroup "lsp formatting provider" - [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullCaps "test/testdata/format" $ do + [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullLatestClientCaps "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 - result@(Left (ResponseError reason message Nothing)) -> case reason of + result@(Left (TResponseError reason message Nothing)) -> case reason of (InR ErrorCodes_MethodNotFound) -> pure () -- No formatter (InR ErrorCodes_InvalidRequest) | "No plugin" `T.isPrefixOf` message -> pure () _ -> 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" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullLatestClientCaps "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" diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index ad42ba3003..150f9cdb04 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -12,13 +12,13 @@ import Test.Hls.Command tests :: TestTree tests = testGroup "behaviour on malformed projects" [ testCase "Missing module diagnostic" $ do - runSession hlsLspCommand fullCaps "test/testdata/missingModuleTest/missingModule/" $ do + runSession hlsLspCommand fullLatestClientCaps "test/testdata/missingModuleTest/missingModule/" $ do doc <- openDoc "src/MyLib.hs" "haskell" [diag] <- waitForDiagnosticsFrom doc liftIO $ assertBool "missing module name" $ "MyLib" `T.isInfixOf` (diag ^. L.message) liftIO $ assertBool "module missing context" $ "may not be listed" `T.isInfixOf` (diag ^. L.message) , testCase "Missing module diagnostic - no matching prefix" $ do - runSession hlsLspCommand fullCaps "test/testdata/missingModuleTest/noPrefixMatch/" $ do + runSession hlsLspCommand fullLatestClientCaps "test/testdata/missingModuleTest/noPrefixMatch/" $ do doc <- openDoc "app/Other.hs" "haskell" [diag] <- waitForDiagnosticsFrom doc liftIO $ assertBool "missing module name" $ diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs index 1c7a8b0480..5a06026b53 100644 --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -11,7 +11,7 @@ import Test.Hls.Command tests :: TestTree tests = testGroup "hie-bios" [ testCase "loads main-is module" $ do - runSession hlsLspCommand fullCaps "test/testdata/hieBiosMainIs" $ do + runSession hlsLspCommand fullLatestClientCaps "test/testdata/hieBiosMainIs" $ do _ <- openDoc "Main.hs" "haskell" (diag:_) <- waitForDiagnostics liftIO $ "Top-level binding with no type signature:" `T.isInfixOf` (diag ^. L.message) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 36fa4e963a..ed82a02350 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -77,7 +77,7 @@ formatLspConfig :: Text -> Config formatLspConfig provider = def { formattingProvider = provider } progressCaps :: ClientCapabilities -progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)} +progressCaps = fullLatestClientCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)} data ProgressMessage = ProgressCreate WorkDoneProgressCreateParams @@ -165,8 +165,8 @@ updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles created expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion expectedIn a as = a `elem` as @? "Unexpected " ++ show a -getMessageResult :: TResponseMessage m -> MessageResult m +getMessageResult :: Show (ErrorData m) => TResponseMessage m -> MessageResult m getMessageResult rsp = case rsp ^. L.result of - Right x -> x - Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err + Right x -> x + Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err