From c51dc57ea5638b09ae4336e1f087b38029306e7e Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 8 May 2020 15:03:03 +0530 Subject: [PATCH] Make ResponseMessage use Either again --- .../src/Language/Haskell/LSP/Types/Types.hs | 37 ++++++++++--------- .../Haskell/LSP/Types/WorkspaceFolders.hs | 1 - src/Language/Haskell/LSP/Control.hs | 3 -- src/Language/Haskell/LSP/Core.hs | 24 +++--------- 4 files changed, 25 insertions(+), 40 deletions(-) diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Types.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Types.hs index 7ccd5cac3..2d55dbc47 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Types.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Types.hs @@ -36,8 +36,6 @@ import Language.Haskell.LSP.Types.WorkspaceFolders import Data.Kind import Data.Aeson import Data.Text -import Data.Maybe -import Control.Monad import GHC.Generics -- --------------------------------------------------------------------- @@ -206,8 +204,7 @@ data ResponseMessage (m :: Method p Request) = ResponseMessage { _jsonrpc :: Text , _id :: Maybe (LspId m) - , _result :: Maybe (ResponseParams m) - , _error :: Maybe ResponseError + , _result :: Either ResponseError (ResponseParams m) } deriving Generic deriving instance Eq (ResponseParams m) => Eq (ResponseMessage m) @@ -215,22 +212,28 @@ deriving instance Read (ResponseParams m) => Read (ResponseMessage m) deriving instance Show (ResponseParams m) => Show (ResponseMessage m) instance (ToJSON (ResponseParams m)) => ToJSON (ResponseMessage m) where - toJSON = genericToJSON lspOptions - toEncoding = genericToEncoding lspOptions + toJSON (ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result }) + = object + [ "jsonrpc" .= jsonrpc + , "id" .= lspid + , case result of + Left err -> "error" .= err + Right a -> "result" .= a + ] instance FromJSON (ResponseParams a) => FromJSON (ResponseMessage a) where parseJSON = withObject "Response" $ \o -> do - rsp <- ResponseMessage - <$> o .: "jsonrpc" - <*> o .: "id" - -- It is important to use .:! so that result = null gets decoded as Just Nothing - <*> o .:! "result" - <*> o .:! "error" - -- We make sure that one of them is present. Without this check we can end up - -- parsing a Request as a ResponseMessage. - unless (isJust (_result rsp) || isJust (_error rsp)) $ - fail "ResponseMessage must either have a result or an error" - pure rsp + _jsonrpc <- o .: "jsonrpc" + _id <- o .: "id" + -- It is important to use .:! so that "result = null" (without error) gets decoded as Just Null + _result <- o .:! "result" + _error <- o .:? "error" + result <- case (_error, _result) of + ((Just err), Nothing ) -> pure $ Left err + (Nothing , (Just res)) -> pure $ Right res + ((Just _err), (Just _res)) -> fail $ "both error and result cannot be present: " ++ show o + (Nothing, Nothing) -> fail "both error and result cannot be Nothing" + return $ ResponseMessage _jsonrpc _id $ result -- --------------------------------------------------------------------- {- diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs index a72394b96..bbcc141a7 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs @@ -120,4 +120,3 @@ data DidChangeWorkspaceFoldersParams = deriveJSON lspOptions ''DidChangeWorkspaceFoldersParams - diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index 5cafd0122..52a726630 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -1,7 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 783070fef..d23c84b98 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -539,14 +539,7 @@ handleMessage dispatcherProc tvarDat jsonStr = do let msg = T.pack $ unwords ["haskell-lsp: got error while decoding response:", show e, "in", show resobj] sendErrorLog tvarDat msg f (Left $ J.ResponseError J.ParseError msg Nothing) - J.Success (res :: J.ResponseMessage m) -> case res ^. J.error of - Just err -> f (Left err) - Nothing -> case res ^. J.result of - Nothing -> do - let msg = T.pack $ unwords ["haskell-lsp: Got neither a result nor an error in response: ", show resobj] - sendErrorLog tvarDat msg - f (Left $ J.ResponseError J.ParseError msg Nothing) - Just result -> f (Right result) + J.Success (res :: J.ResponseMessage m) -> f (res ^. J.result) J.IsServerEither -> case f of Nothing -> sendErrorLog tvarDat $ @@ -557,14 +550,7 @@ handleMessage dispatcherProc tvarDat jsonStr = do let msg = T.pack $ unwords ["haskell-lsp: got error while decoding response:", show e, "in", show resobj] sendErrorLog tvarDat msg f' (Left $ J.ResponseError J.ParseError msg Nothing) - J.Success (res :: J.ResponseMessage m) -> case res ^. J.error of - Just err -> f' (Left err) - Nothing -> case res ^. J.result of - Just result -> f' (Right result) - Nothing -> do - let msg = T.pack $ unwords ["haskell-lsp: Got neither a result nor an error in response: ", show res] - sendErrorLog tvarDat msg - f' (Left $ J.ResponseError J.ParseError msg Nothing) + J.Success (res :: J.ResponseMessage m) -> f' (res ^. J.result) -- capability based handlers handle json cmd = do ctx <- readTVarIO tvarDat @@ -573,10 +559,10 @@ handleMessage dispatcherProc tvarDat jsonStr = do -- --------------------------------------------------------------------- makeResponseMessage :: J.LspId m -> J.ResponseParams m -> J.ResponseMessage m -makeResponseMessage rid result = J.ResponseMessage "2.0" (Just rid) (Just result) Nothing +makeResponseMessage rid result = J.ResponseMessage "2.0" (Just rid) (Right result) makeResponseError :: J.LspId m -> J.ResponseError -> J.ResponseMessage m -makeResponseError origId err = J.ResponseMessage "2.0" (Just origId) Nothing (Just err) +makeResponseError origId err = J.ResponseMessage "2.0" (Just origId) (Left err) -- --------------------------------------------------------------------- @@ -593,7 +579,7 @@ sendErrorResponseE TVar (LanguageContextData config) -> J.SMethod m -> J.LspId (m :: J.Method J.FromClient J.Request) -> J.ResponseError -> IO () sendErrorResponseE sf m origId err = do - sendToClient sf $ J.FromServerRsp m (J.ResponseMessage "2.0" (Just origId) Nothing (Just err)) + sendToClient sf $ J.FromServerRsp m (makeResponseError origId err) sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO () sendErrorLog tv msg =