Allow the withResponse handler to idiomatically return an error (#396)

* Allow the withResponse handler to idiomatically return an error

An LSP response message can have either a result or an error
field. Expose this in the handler by having a return type

    type ResponseBody resp = Either ResponseError resp

Closes #395

* Apply hint to use lambdacase

* Simplify, based on @ndmitchell review feedback.

* Remove ResponseBody by inlining it, fmap some results

Author: alanz

src/Development/IDE/LSP/HoverDefinition.hs

@@ -20,8 +20,8 @@ import           Language.Haskell.LSP.Types
 
 import qualified Data.Text as T
 
-gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams
-hover          :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)
+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
+hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
 gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
 hover          = request "Hover"      getAtPoint     Nothing      foundHover
 
@@ -43,12 +43,12 @@ request
   -> (a -> b)
   -> IdeState
   -> TextDocumentPositionParams
-  -> IO b
+  -> IO (Either ResponseError b)
 request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
     mbResult <- case uriToFilePath' uri of
         Just path -> logAndRunRequest label getResults ide pos path
         Nothing   -> pure Nothing
-    pure $ maybe notFound found mbResult
+    pure $ Right $ maybe notFound found mbResult
 
 logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
 logAndRunRequest label getResults ide pos path = do

src/Development/IDE/LSP/LanguageServer.hs

@@ -134,8 +134,10 @@ runLanguageServer options userHandlers getIdeState = do
                                 "Message: " ++ show x ++ "\n" ++
                                 "Exception: " ++ show e
                     Response x@RequestMessage{_id, _params} wrap act ->
-                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ 
-                            \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
+                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
+                            \case
+                              Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)
+                              Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing
                     ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
                         checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
                             \(res, newReq) -> do
@@ -191,7 +193,7 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
 -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
 data Message
-    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
+    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp))
     -- | Used for cases in which we need to send not only a response,
     --   but also an additional request to the client.
     --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

src/Development/IDE/LSP/Outline.hs

@@ -34,12 +34,12 @@ setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
   }
 
 moduleOutline
-  :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO DSResult
+  :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
 moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
   = case uriToFilePath uri of
     Just (toNormalizedFilePath -> fp) -> do
       mb_decls <- runAction ideState $ use GetParsedModule fp
-      pure $ case mb_decls of
+      pure $ Right $ case mb_decls of
         Nothing -> DSDocumentSymbols (List [])
         Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })
           -> let
@@ -61,7 +61,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI
                DSDocumentSymbols (List allSymbols)
 
 
-    Nothing -> pure $ DSDocumentSymbols (List [])
+    Nothing -> pure $ Right $ DSDocumentSymbols (List [])
 
 documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol
 documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

src/Development/IDE/LSP/Server.hs

@@ -16,17 +16,16 @@ import qualified Language.Haskell.LSP.Core as LSP
 import qualified Language.Haskell.LSP.Messages as LSP
 import Development.IDE.Core.Service
 
-
 data WithMessage = WithMessage
     {withResponse :: forall m req resp . (Show m, Show req) =>
         (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
-        (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work
+        (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
         Maybe (LSP.Handler (RequestMessage m req resp))
     ,withNotification :: forall m req . (Show m, Show req) =>
         Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
         (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
         Maybe (LSP.Handler (NotificationMessage m req))
-    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody. 
+    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
         (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
         (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
         (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

src/Development/IDE/Plugin.hs

@@ -26,8 +26,9 @@ instance Monoid Plugin where
     mempty = def
 
 
-codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO [CAResult]) -> Plugin
+codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin
 codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.codeActionHandler = withResponse RspCodeAction g
     }
-    where g lsp state (CodeActionParams a b c _) = List <$> f lsp state a b c
+    where
+      g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

src/Development/IDE/Plugin/CodeAction.hs

@@ -48,7 +48,7 @@ codeAction
     -> TextDocumentIdentifier
     -> Range
     -> CodeActionContext
-    -> IO [CAResult]
+    -> IO (Either ResponseError [CAResult])
 codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
     -- disable logging as its quite verbose
     -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
@@ -57,7 +57,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
     (ideOptions, parsedModule) <- runAction state $
       (,) <$> getIdeOptions
           <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
-    pure
+    pure $ Right
         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
         | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
@@ -68,21 +68,21 @@ codeLens
     :: LSP.LspFuncs ()
     -> IdeState
     -> CodeLensParams
-    -> IO (List CodeLens)
+    -> IO (Either ResponseError (List CodeLens))
 codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
-    case uriToFilePath' uri of
+    fmap (Right . List) $ case uriToFilePath' uri of
       Just (toNormalizedFilePath -> filePath) -> do
         _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
         diag <- getDiagnostics ideState
         hDiag <- getHiddenDiagnostics ideState
-        pure $ List
+        pure
           [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
           | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag
           , dFile == filePath
           , (title, tedit) <- suggestSignature False dDiag
           , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
           ]
-      Nothing -> pure $ List []
+      Nothing -> pure []
 
 -- | Execute the "typesignature.add" command.
 executeAddSignatureCommand
@@ -93,7 +93,7 @@ executeAddSignatureCommand
 executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
     | _command == "typesignature.add"
     , Just (List [edit]) <- _arguments
-    , Success wedit <- fromJSON edit 
+    , Success wedit <- fromJSON edit
     = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
     | otherwise
     = return (Null, Nothing)

src/Development/IDE/Plugin/Completions.hs

@@ -58,13 +58,13 @@ getCompletionsLSP
     :: LSP.LspFuncs ()
     -> IdeState
     -> CompletionParams
-    -> IO CompletionResponseResult
+    -> IO (Either ResponseError CompletionResponseResult)
 getCompletionsLSP lsp ide
   CompletionParams{_textDocument=TextDocumentIdentifier uri
                   ,_position=position
                   ,_context=completionContext} = do
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
-    case (contents, uriToFilePath' uri) of
+    fmap Right $ case (contents, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath path
         (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)