1dc4e33 · ghcide · git.iko.soy

git.iko.soy/ghcide

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

commit1dc4e33ec2e8acad3d029e53c4677b69aa43658f authorAlan Zimmerman <alan.zimm@gmail.com> dateMon 3 Feb 2020, 12:19 (7 years ago) parent52f3fea

7 files changed+26−24

compare with master

unifiedsplit

src/Development/IDE/LSP/HoverDefinition.hs+4−4 src/Development/IDE/LSP/LanguageServer.hs+5−3 src/Development/IDE/LSP/Outline.hs+3−3 src/Development/IDE/LSP/Server.hs+2−3 src/Development/IDE/Plugin.hs+3−2 src/Development/IDE/Plugin/CodeAction.hs+7−7 src/Development/IDE/Plugin/Completions.hs+2−2

src/Development/IDE/LSP/HoverDefinition.hs+4−4

@@ -20,8 +20,8 @@ import Language.Haskell.LSP.Types

2020

2121import qualified Data.Text as T

2222

23−gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams

24−hover :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)

23+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)

24+hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))

2525gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc

2626hover = request "Hover" getAtPoint Nothing foundHover

2727

@@ -43,12 +43,12 @@ request

4343 -> (a -> b)

4444 -> IdeState

4545 -> TextDocumentPositionParams

46− -> IO b

46+ -> IO (Either ResponseError b)

4747request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

4848 mbResult <- case uriToFilePath' uri of

4949 Just path -> logAndRunRequest label getResults ide pos path

5050 Nothing -> pure Nothing

51− pure $ maybe notFound found mbResult

51+ pure $ Right $ maybe notFound found mbResult

5252

5353logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b

5454logAndRunRequest label getResults ide pos path = do

src/Development/IDE/LSP/LanguageServer.hs+5−3

@@ -134,8 +134,10 @@ runLanguageServer options userHandlers getIdeState = do

134134 "Message: " ++ show x ++ "\n" ++

135135 "Exception: " ++ show e

136136 Response x@RequestMessage{_id, _params} wrap act ->

137− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

138− \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

137+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

138+ \case

139+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

140+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

139141 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

140142 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

141143 \(res, newReq) -> do

@@ -191,7 +193,7 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

191193-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

192194-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

193195data Message

194− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)

196+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp))

195197 -- | Used for cases in which we need to send not only a response,

196198 -- but also an additional request to the client.

197199 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

src/Development/IDE/LSP/Outline.hs+3−3

@@ -34,12 +34,12 @@ setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x

3434 }

3535

3636moduleOutline

37− :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO DSResult

37+ :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

3838moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

3939 = case uriToFilePath uri of

4040 Just (toNormalizedFilePath -> fp) -> do

4141 mb_decls <- runAction ideState $ use GetParsedModule fp

42− pure $ case mb_decls of

42+ pure $ Right $ case mb_decls of

4343 Nothing -> DSDocumentSymbols (List [])

4444 Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })

4545 -> let

@@ -61,7 +61,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

6161 DSDocumentSymbols (List allSymbols)

6262

6363

64− Nothing -> pure $ DSDocumentSymbols (List [])

64+ Nothing -> pure $ Right $ DSDocumentSymbols (List [])

6565

6666documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol

6767documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

src/Development/IDE/LSP/Server.hs+2−3

@@ -16,17 +16,16 @@ import qualified Language.Haskell.LSP.Core as LSP

1616import qualified Language.Haskell.LSP.Messages as LSP

1717import Development.IDE.Core.Service

1818

19−

2019data WithMessage = WithMessage

2120 {withResponse :: forall m req resp . (Show m, Show req) =>

2221 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

23− (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work

22+ (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

2423 Maybe (LSP.Handler (RequestMessage m req resp))

2524 ,withNotification :: forall m req . (Show m, Show req) =>

2625 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

2726 (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work

2827 Maybe (LSP.Handler (NotificationMessage m req))

29− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

28+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

3029 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

3130 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

3231 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

src/Development/IDE/Plugin.hs+3−2

@@ -26,8 +26,9 @@ instance Monoid Plugin where

2626 mempty = def

2727

2828

29−codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO [CAResult]) -> Plugin

29+codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin

3030codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{

3131 LSP.codeActionHandler = withResponse RspCodeAction g

3232 }

33− where g lsp state (CodeActionParams a b c _) = List <$> f lsp state a b c

33+ where

34+ g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

src/Development/IDE/Plugin/CodeAction.hs+7−7

@@ -48,7 +48,7 @@ codeAction

4848 -> TextDocumentIdentifier

4949 -> Range

5050 -> CodeActionContext

51− -> IO [CAResult]

51+ -> IO (Either ResponseError [CAResult])

5252codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do

5353 -- disable logging as its quite verbose

5454 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

@@ -57,7 +57,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag

5757 (ideOptions, parsedModule) <- runAction state $

5858 (,) <$> getIdeOptions

5959 <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri

60− pure

60+ pure $ Right

6161 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

6262 | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x

6363 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

@@ -68,21 +68,21 @@ codeLens

6868 :: LSP.LspFuncs ()

6969 -> IdeState

7070 -> CodeLensParams

71− -> IO (List CodeLens)

71+ -> IO (Either ResponseError (List CodeLens))

7272codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

73− case uriToFilePath' uri of

73+ fmap (Right . List) $ case uriToFilePath' uri of

7474 Just (toNormalizedFilePath -> filePath) -> do

7575 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

7676 diag <- getDiagnostics ideState

7777 hDiag <- getHiddenDiagnostics ideState

78− pure $ List

78+ pure

7979 [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

8080 | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag

8181 , dFile == filePath

8282 , (title, tedit) <- suggestSignature False dDiag

8383 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

8484 ]

85− Nothing -> pure $ List []

85+ Nothing -> pure []

8686

8787-- | Execute the "typesignature.add" command.

8888executeAddSignatureCommand

@@ -93,7 +93,7 @@ executeAddSignatureCommand

9393executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

9494 | _command == "typesignature.add"

9595 , Just (List [edit]) <- _arguments

96− , Success wedit <- fromJSON edit

96+ , Success wedit <- fromJSON edit

9797 = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

9898 | otherwise

9999 = return (Null, Nothing)

src/Development/IDE/Plugin/Completions.hs+2−2

@@ -58,13 +58,13 @@ getCompletionsLSP

5858 :: LSP.LspFuncs ()

5959 -> IdeState

6060 -> CompletionParams

61− -> IO CompletionResponseResult

61+ -> IO (Either ResponseError CompletionResponseResult)

6262getCompletionsLSP lsp ide

6363 CompletionParams{_textDocument=TextDocumentIdentifier uri

6464 ,_position=position

6565 ,_context=completionContext} = do

6666 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

67− case (contents, uriToFilePath' uri) of

67+ fmap Right $ case (contents, uriToFilePath' uri) of

6868 (Just cnts, Just path) -> do

6969 let npath = toNormalizedFilePath path

7070 (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)