Merge pull request #479 from joyfulmantis/mpjs-metamodel2-no-tresponseerrors

Replace some TResponseError with ResponseError

Author: michaelpj

lsp-test/src/Language/LSP/Test.hs

@@ -522,7 +522,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) (toUntypedResponseError err))
+    Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
 
 -- | Returns the code actions in the specified range.
 getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
@@ -533,7 +533,7 @@ getCodeActions doc range = do
   case rsp ^. result of
     Right (InL xs) -> return xs
     Right (InR _) -> return []
-    Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) (toUntypedResponseError error))
+    Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)
 
 -- | Returns all the code actions in a document by
 -- querying the code actions at each of the current
@@ -550,7 +550,7 @@ getAllCodeActions doc = do
       TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)
 
       case res of
-        Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) (toUntypedResponseError e))
+        Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
         Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs)
         Right (InR _) -> pure acc
 
@@ -725,7 +725,7 @@ getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResu
 getResponseResult rsp =
   case rsp ^. result of
     Right x -> x
-    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) (toUntypedResponseError err)
+    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err
 
 -- | Applies formatting to the specified document.
 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()

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 $ TResponseError ErrorCodes_InternalError t Nothing
+          Left t -> resp $ Left $ ResponseError ErrorCodes_InternalError t Nothing
           Right tokens -> resp $ Right $ InL tokens
     ]

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

@@ -132,7 +132,8 @@ data TResponseMessage (m :: Method f Request) =
   TResponseMessage
     { _jsonrpc :: Text
     , _id      :: Maybe (LspId m)
-    , _result  :: Either (TResponseError m) (MessageResult m)
+    -- TODO: use `TResponseError m` for the error type, this will require quite a lot of adaptation downstream
+    , _result  :: Either ResponseError (MessageResult m)
     } deriving stock Generic
 
 deriving stock instance (Eq   (MessageResult m), Eq (ErrorData m)) => Eq (TResponseMessage m)

lsp-types/test/JsonSpec.hs

@@ -140,6 +140,9 @@ instance {-# OVERLAPPING #-} Arbitrary (Maybe Void) where
 instance (ErrorData m ~ Maybe Void) => Arbitrary (TResponseError m) where
   arbitrary = TResponseError <$> arbitrary <*> arbitrary <*> pure Nothing
 
+instance Arbitrary ResponseError where
+  arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing
+
 instance (Arbitrary (MessageResult m), ErrorData m ~ Maybe Void) => Arbitrary (TResponseMessage m) where
   arbitrary = TResponseMessage <$> arbitrary <*> arbitrary <*> arbitrary
 

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

@@ -142,7 +142,7 @@ newtype ClientMessageHandler f (t :: MessageKind) (m :: Method ClientToServer t)
 -- | The type of a handler that handles requests and notifications coming in
 -- 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 (TResponseError m) (MessageResult m) -> f ()) -> f ()
+  Handler f (m :: Method _from Request)      = TRequestMessage m -> (Either ResponseError (MessageResult m) -> f ()) -> f ()
   Handler f (m :: Method _from Notification) = TNotificationMessage m -> f ()
 
 -- | How to convert two isomorphic data structures between each other.
@@ -287,7 +287,7 @@ data ServerDefinition config = forall m a.
       -- indicating what went wrong. The parsed configuration object will be
       -- stored internally and can be accessed via 'config'.
       -- It is also called on the `initializationOptions` field of the InitializeParams
-    , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) a)
+    , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError 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
@@ -319,7 +319,7 @@ data ServerDefinition config = forall m a.
 -- | A function that a 'Handler' is passed that can be used to respond to a
 -- request with either an error, or the response params.
 newtype ServerResponseCallback (m :: Method ServerToClient Request)
-  = ServerResponseCallback (Either (TResponseError m) (MessageResult m) -> IO ())
+  = ServerResponseCallback (Either ResponseError (MessageResult m) -> IO ())
 
 -- | Return value signals if response handler was inserted successfully
 -- Might fail if the id was already in the map
@@ -344,7 +344,7 @@ sendNotification m params =
 sendRequest :: forall (m :: Method ServerToClient Request) f config. MonadLsp config f
             => SServerMethod m
             -> MessageParams m
-            -> (Either (TResponseError m) (MessageResult m) -> f ())
+            -> (Either ResponseError (MessageResult m) -> f ())
             -> f (LspId m)
 sendRequest m params resHandler = do
   reqId <- IdInt <$> freshLspId

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

@@ -163,9 +163,9 @@ initializeRequestHandler 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 :: (TResponseError Method_Initialize -> IO ()) -> E.SomeException -> IO (Maybe a)
+    initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a)
     initializeErrorHandler sendResp e = do
-        sendResp $ TResponseError ErrorCodes_InternalError msg Nothing
+        sendResp $ ResponseError ErrorCodes_InternalError msg Nothing
         pure Nothing
       where
         msg = T.pack $ unwords ["Error on initialize:", show e]
@@ -350,7 +350,7 @@ handle' logger mAction m msg = do
   env <- getLspEnv
   let Handlers{reqHandlers, notHandlers} = resHandlers env
 
-  let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either (TResponseError m1) (MessageResult m1) -> IO ()
+  let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO ()
       mkRspCb req (Left  err) = runLspT env $ sendToClient $
         FromServerRsp (req ^. method) $ TResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err)
       mkRspCb req (Right rsp) = runLspT env $ sendToClient $
@@ -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 = TResponseError ErrorCodes_MethodNotFound errorMsg Nothing
+                err = ResponseError ErrorCodes_MethodNotFound errorMsg Nothing
             sendToClient $
               FromServerRsp (msg ^. method) $ TResponseMessage "2.0" (Just (msg ^. LSP.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 = TResponseError ErrorCodes_MethodNotFound errorMsg Nothing
+              err = ResponseError ErrorCodes_MethodNotFound errorMsg Nothing
           sendToClient $
             FromServerRsp (req ^. method) $ TResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err)
   where