From f42e78a94fc140937474c44cf1d123d4e50216f8 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Wed, 5 Jun 2024 10:01:28 +0100 Subject: [PATCH] Use typed response errors I have a branch adapting to this in HLS, it wasn't so bad. Fixes #586 --- lsp-test/src/Language/LSP/Test.hs | 20 +++++++++---------- lsp-test/src/Language/LSP/Test/Exceptions.hs | 3 +-- lsp-test/src/Language/LSP/Test/Session.hs | 2 +- lsp-test/test/DummyServer.hs | 2 +- lsp-types/ChangeLog.md | 1 + .../Language/LSP/Protocol/Message/Types.hs | 3 +-- lsp-types/test/JsonSpec.hs | 2 +- lsp/ChangeLog.md | 1 + lsp/src/Language/LSP/Server/Core.hs | 10 +++++----- lsp/src/Language/LSP/Server/Processing.hs | 10 +++++----- 10 files changed, 27 insertions(+), 27 deletions(-) diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs index b9b29297..3c73bfb7 100644 --- a/lsp-test/src/Language/LSP/Test.hs +++ b/lsp-test/src/Language/LSP/Test.hs @@ -674,7 +674,7 @@ getDocumentSymbols doc = do Right (InL xs) -> return (Left xs) Right (InR (InL xs)) -> return (Right xs) Right (InR (InR _)) -> return (Right []) - Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err) + Left err -> throw (UnexpectedResponseError (fromJust rspLid) err) -- | Returns the code actions in the specified range. getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] @@ -685,7 +685,7 @@ getCodeActions doc range = do case rsp ^. L.result of Right (InL xs) -> return xs Right (InR _) -> return [] - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) + Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) {- | Returns the code actions in the specified range, resolving any with a non empty _data_ field. @@ -713,7 +713,7 @@ getAllCodeActions doc = do TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx) case res of - Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) + Left e -> throw (UnexpectedResponseError (fromJust rspLid) e) Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs) Right (InR _) -> pure acc @@ -781,7 +781,7 @@ resolveCodeAction ca = do rsp <- request SMethod_CodeActionResolve ca case rsp ^. L.result of Right ca -> return ca - Left er -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) er) + Left er -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) er) {- | If a code action contains a _data_ field: resolves the code action, then executes it. Otherwise, just executes it. @@ -849,7 +849,7 @@ resolveCompletion ci = do rsp <- request SMethod_CompletionItemResolve ci case rsp ^. L.result of Right ci -> return ci - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) + Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) -- | Returns the references for the position in the document. getReferences :: @@ -937,11 +937,11 @@ getHighlights doc pos = {- | Checks the response for errors and throws an exception if needed. Returns the result if successful. -} -getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m +getResponseResult :: (Show (ErrorData m)) => TResponseMessage m -> MessageResult m getResponseResult rsp = case rsp ^. L.result of Right x -> x - Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err + Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () @@ -984,7 +984,7 @@ resolveCodeLens cl = do rsp <- request SMethod_CodeLensResolve cl case rsp ^. L.result of Right cl -> return cl - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) + Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) -- | Returns the inlay hints in the specified range. getInlayHints :: TextDocumentIdentifier -> Range -> Session [InlayHint] @@ -1006,7 +1006,7 @@ resolveInlayHint ih = do rsp <- request SMethod_InlayHintResolve ih case rsp ^. L.result of Right ih -> return ih - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) + Left error -> throw (UnexpectedResponseError (fromJust $ rsp ^. L.id) error) -- | Pass a param and return the response from `prepareCallHierarchy` prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem] @@ -1021,7 +1021,7 @@ outgoingCalls = resolveRequestWithListResp SMethod_CallHierarchyOutgoingCalls -- | Send a request and receive a response with list. resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a. - (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null)) => + (Show (ErrorData m), MessageResult m ~ ([a] |? Null)) => SMethod m -> MessageParams m -> Session [a] diff --git a/lsp-test/src/Language/LSP/Test/Exceptions.hs b/lsp-test/src/Language/LSP/Test/Exceptions.hs index 5efb7b8c..12a97cf7 100644 --- a/lsp-test/src/Language/LSP/Test/Exceptions.hs +++ b/lsp-test/src/Language/LSP/Test/Exceptions.hs @@ -17,11 +17,10 @@ data SessionException | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics | IncorrectApplyEditRequest String - | UnexpectedResponseError SomeLspId ResponseError + | forall m . Show (ErrorData m) => UnexpectedResponseError (LspId m) (TResponseError m) | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage | MessageSendError Value IOError - deriving (Eq) instance Exception SessionException diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index 2bf24371..153e0d6b 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -349,7 +349,7 @@ updateStateC = awaitForever $ \msg -> do sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) $ if null errs then Right configs - else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> T.pack (show errs)) Nothing + else Left $ TResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> T.pack (show errs)) Nothing _ -> pure () unless ( (ignoringLogNotifications state && isLogNotification msg) diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs index 9112f9e2..bd36551e 100644 --- a/lsp-test/test/DummyServer.hs +++ b/lsp-test/test/DummyServer.hs @@ -255,7 +255,7 @@ handlers = , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do let tokens = makeSemanticTokens defaultSemanticTokensLegend [SemanticTokenAbsolute 0 1 2 SemanticTokenTypes_Type []] case tokens of - Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing + Left t -> resp $ Left $ TResponseError (InR ErrorCodes_InternalError) t Nothing Right tokens -> resp $ Right $ InL tokens , requestHandler SMethod_TextDocumentInlayHint $ \req resp -> do let TRequestMessage _ _ _ params = req diff --git a/lsp-types/ChangeLog.md b/lsp-types/ChangeLog.md index 1190de8e..ee75083c 100644 --- a/lsp-types/ChangeLog.md +++ b/lsp-types/ChangeLog.md @@ -3,6 +3,7 @@ ## Unreleased - Add support for identifying client and server capabilities associated with a method. +- `TResponseMessage` now contains a `TResponseError` instead of a `ResponseError` ## 2.2.0.0 -- 2024-04-29 diff --git a/lsp-types/src/Language/LSP/Protocol/Message/Types.hs b/lsp-types/src/Language/LSP/Protocol/Message/Types.hs index c7fda93f..80b15c98 100644 --- a/lsp-types/src/Language/LSP/Protocol/Message/Types.hs +++ b/lsp-types/src/Language/LSP/Protocol/Message/Types.hs @@ -192,8 +192,7 @@ toUntypedResponseError (TResponseError c m d) = ResponseError c m (fmap toJSON d data TResponseMessage (m :: Method f Request) = TResponseMessage { _jsonrpc :: Text , _id :: Maybe (LspId m) - , -- TODO: use `TResponseError m` for the error type, this will require quite a lot of adaptation downstream - _result :: Either ResponseError (MessageResult m) + , _result :: Either (TResponseError m) (MessageResult m) } deriving stock (Generic) diff --git a/lsp-types/test/JsonSpec.hs b/lsp-types/test/JsonSpec.hs index 6d7da36c..b8e9dd80 100644 --- a/lsp-types/test/JsonSpec.hs +++ b/lsp-types/test/JsonSpec.hs @@ -77,7 +77,7 @@ spec = do let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"error\": { \"code\": -32700, \"message\": \"oh no\", \"data\": null }}" in J.decode input `shouldBe` Just - ( (TResponseMessage "2.0" (Just (IdInt 123)) (Left $ ResponseError (InR ErrorCodes_ParseError) "oh no" (Just J.Null))) :: + ( (TResponseMessage "2.0" (Just (IdInt 123)) (Left $ TResponseError (InR ErrorCodes_ParseError) "oh no" (Just J.Null))) :: TResponseMessage ('Method_CustomMethod "hello") ) it "throws if neither result nor error is present" $ do diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md index 35d6d0b8..589de6f1 100644 --- a/lsp/ChangeLog.md +++ b/lsp/ChangeLog.md @@ -4,6 +4,7 @@ - Drop dependency on `uuid` and `random` - Fix handling of `rootPath` in `intializeParams` +- Update to newer `lsp-types` ## 2.6.0.0 diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 86e8a27d..3adf93ca 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -74,7 +74,7 @@ data LspCoreLog NewConfig J.Value | ConfigurationParseError J.Value T.Text | ConfigurationNotSupported - | BadConfigurationResponse ResponseError + | BadConfigurationResponse (TResponseError Method_WorkspaceConfiguration) | WrongConfigSections [J.Value] | forall m. CantRegister (SMethod m) @@ -177,7 +177,7 @@ newtype ClientMessageHandler f (t :: MessageKind) (m :: Method ClientToServer t) from the server or client -} type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where - Handler f (m :: Method _from Request) = TRequestMessage m -> (Either ResponseError (MessageResult m) -> f ()) -> f () + Handler f (m :: Method _from Request) = TRequestMessage m -> (Either (TResponseError m) (MessageResult m) -> f ()) -> f () Handler f (m :: Method _from Notification) = TNotificationMessage m -> f () -- | How to convert two isomorphic data structures between each other. @@ -348,7 +348,7 @@ data ServerDefinition config = forall m a. -- the new config. Servers that want to react to config changes should provide -- a callback here, it is not sufficient to just add e.g. a @workspace/didChangeConfiguration@ -- handler. - , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError a) + , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) a) -- ^ Called *after* receiving the @initialize@ request and *before* -- returning the response. This callback will be invoked to offer the -- language server implementation the chance to create any processes or @@ -383,7 +383,7 @@ data ServerDefinition config = forall m a. request with either an error, or the response params. -} newtype ServerResponseCallback (m :: Method ServerToClient Request) - = ServerResponseCallback (Either ResponseError (MessageResult m) -> IO ()) + = ServerResponseCallback (Either (TResponseError m) (MessageResult m) -> IO ()) {- | Return value signals if response handler was inserted successfully Might fail if the id was already in the map @@ -412,7 +412,7 @@ sendRequest :: MonadLsp config f => SServerMethod m -> MessageParams m -> - (Either ResponseError (MessageResult m) -> f ()) -> + (Either (TResponseError m) (MessageResult m) -> f ()) -> f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index 9cfca61b..4c8077b1 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -196,9 +196,9 @@ initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err) - initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) + initializeErrorHandler :: (TResponseError Method_Initialize -> IO ()) -> E.SomeException -> IO (Maybe a) initializeErrorHandler sendResp e = do - sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing + sendResp $ TResponseError (InR ErrorCodes_InternalError) msg Nothing pure Nothing where msg = T.pack $ unwords ["Error on initialize:", show e] @@ -518,13 +518,13 @@ handle' logger mAction m msg = do (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing - sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> m () + sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either (TResponseError m1) (MessageResult m1) -> m () sendResponse req res = sendToClient $ FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) res requestDuringShutdown :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> m () requestDuringShutdown req = do logger <& MessageDuringShutdown m `WithSeverity` Warning - sendResponse req (Left (ResponseError (InR ErrorCodes_InvalidRequest) "Server is shutdown" Nothing)) + sendResponse req (Left (TResponseError (InR ErrorCodes_InvalidRequest) "Server is shutdown" Nothing)) notificationDuringShutdown :: m () notificationDuringShutdown = logger <& MessageDuringShutdown m `WithSeverity` Warning @@ -541,7 +541,7 @@ handle' logger mAction m msg = do missingRequestHandler req = do logger <& MissingHandler False m `WithSeverity` Error let errorMsg = T.pack $ unwords ["No handler for: ", show m] - err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing + err = TResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendResponse req (Left err) progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m ()