ResponseError takes LSPErrorCodes and ErrorCodes

Author: joyfulmantis

lsp-test/test/DummyServer.hs

@@ -241,6 +241,6 @@ 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 ErrorCodes_InternalError t Nothing
+          Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing
           Right tokens -> resp $ Right $ InL tokens
     ]

lsp-types/src/Language/LSP/Protocol/Message/Types.hs

@@ -54,12 +54,23 @@ deriveJSON lspOptions ''RequestMessage
 -- | Response error type as defined in the spec.
 data ResponseError =
   ResponseError
-    { _code    :: ErrorCodes
+    { _code    :: LSPErrorCodes |? ErrorCodes
     , _message :: Text
     , _xdata   :: Maybe Value
     } deriving stock (Show, Eq, Generic)
 
-deriveJSON lspOptions ''ResponseError
+deriveToJSON lspOptions ''ResponseError
+instance FromJSON ResponseError where
+    parseJSON = 
+      let errorCode = withObject "ResponseError" $ \v -> ResponseError
+                        <$> v .: "code"
+                        <*> v .: "message"
+                        <*> v .:? "data"
+      in fmap go . errorCode
+      where go :: ResponseError -> ResponseError
+            go x@(ResponseError (InR (ErrorCodes_Custom n)) _ _) = 
+              x{_code = InL (fromOpenEnumBaseType n)}
+            go x = x
 
 -- | Response message type as defined in the spec.
 data ResponseMessage =
@@ -109,7 +120,7 @@ instance (ToJSON (MessageParams m)) => ToJSON (TRequestMessage m) where
 
 data TResponseError (m :: Method f Request) =
   TResponseError
-    { _code    :: ErrorCodes
+    { _code    :: LSPErrorCodes |? ErrorCodes
     , _message :: Text
     , _xdata   :: Maybe (ErrorData m)
     } deriving stock Generic
@@ -118,7 +129,16 @@ deriving stock instance Eq   (ErrorData m) => Eq (TResponseError m)
 deriving stock instance Show (ErrorData m) => Show (TResponseError m)
 
 instance (FromJSON (ErrorData m)) => FromJSON (TResponseError m) where
-  parseJSON = genericParseJSON lspOptions
+  parseJSON = 
+    let errorCode = withObject "ResponseError" $ \v -> TResponseError
+                      <$> v .: "code"
+                      <*> v .: "message"
+                      <*> v .:? "data"
+    in fmap go . errorCode
+    where go :: TResponseError m -> TResponseError m
+          go x@(TResponseError (InR (ErrorCodes_Custom n)) _ _) = 
+            x{_code = InL (fromOpenEnumBaseType n)}
+          go x = x
 instance (ToJSON (ErrorData m)) => ToJSON (TResponseError m) where
   toJSON     = genericToJSON lspOptions
   toEncoding = genericToEncoding lspOptions

lsp-types/test/JsonSpec.hs

@@ -161,6 +161,14 @@ instance Arbitrary ErrorCodes where
       , ErrorCodes_UnknownErrorCode
       ]
 
+instance Arbitrary LSPErrorCodes where
+  arbitrary =
+    elements
+      [ LSPErrorCodes_RequestFailed
+      , LSPErrorCodes_ServerCancelled
+      , LSPErrorCodes_ContentModified
+      , LSPErrorCodes_RequestCancelled
+      ]
 -- ---------------------------------------------------------------------
 
 instance Arbitrary DidChangeWatchedFilesRegistrationOptions where

lsp/src/Language/LSP/Server/Processing.hs

@@ -165,7 +165,7 @@ initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do
 
     initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a)
     initializeErrorHandler sendResp e = do
-        sendResp $ ResponseError ErrorCodes_InternalError msg Nothing
+        sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing
         pure Nothing
       where
         msg = T.pack $ unwords ["Error on initialize:", show e]
@@ -370,7 +370,7 @@ handle' logger mAction m msg = do
         | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg)
         | otherwise -> do
             let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]
-                err = ResponseError ErrorCodes_MethodNotFound errorMsg Nothing
+                err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing
             sendToClient $
               FromServerRsp (msg ^. J.method) $ TResponseMessage "2.0" (Just (msg ^. J.id)) (Left err)
 
@@ -382,7 +382,7 @@ handle' logger mAction m msg = do
         Just h -> liftIO $ h req (mkRspCb req)
         Nothing -> do
           let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]
-              err = ResponseError ErrorCodes_MethodNotFound errorMsg Nothing
+              err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing
           sendToClient $
             FromServerRsp (req ^. J.method) $ TResponseMessage "2.0" (Just (req ^. J.id)) (Left err)
   where