Make ResponseMessage use Either again

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,31 +204,36 @@ 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)
 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
 
 -- ---------------------------------------------------------------------
 {-

haskell-lsp-types/src/Language/Haskell/LSP/Types/WorkspaceFolders.hs

@@ -120,4 +120,3 @@ data DidChangeWorkspaceFoldersParams =
 
 deriveJSON lspOptions ''DidChangeWorkspaceFoldersParams
 
-

src/Language/Haskell/LSP/Control.hs

@@ -1,7 +1,4 @@
 {-# LANGUAGE CPP                 #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE MultiWayIf          #-}
-{-# LANGUAGE BinaryLiterals      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}

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 =