Use typed response errors

I have a branch adapting to this in HLS, it wasn't so bad.

Fixes #586

Author: michaelpj

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]

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
 

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)

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

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
 

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)
 

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

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
 

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

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 ()