Skip to content

Commit 7f3b0f6

Browse files
serrascocreature
serras
authored and
cocreature
committed
Code lens for missing signatures (#224)
* Code lens for missing signatures * Fix tests * Implement suggestions by @cocreature
1 parent 5091a1d commit 7f3b0f6

File tree

4 files changed

+104
-30
lines changed

4 files changed

+104
-30
lines changed

‎src/Development/IDE/LSP/CodeAction.hs

Lines changed: 51 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -8,18 +8,22 @@
88
-- | Go to the definition of a variable.
99
module Development.IDE.LSP.CodeAction
1010
( setHandlersCodeAction
11+
, setHandlersCodeLens
1112
) where
1213

1314
import Language.Haskell.LSP.Types
1415
import Development.IDE.GHC.Compat
1516
import Development.IDE.Core.Rules
17+
import Development.IDE.Core.Shake
1618
import Development.IDE.LSP.Server
19+
import Development.IDE.Types.Location
1720
import qualified Data.HashMap.Strict as Map
1821
import qualified Data.HashSet as Set
1922
import qualified Language.Haskell.LSP.Core as LSP
2023
import Language.Haskell.LSP.VFS
2124
import Language.Haskell.LSP.Messages
2225
import qualified Data.Rope.UTF16 as Rope
26+
import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
2327
import Data.Char
2428
import Data.Maybe
2529
import Data.List.Extra
@@ -42,9 +46,41 @@ codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_cont
4246
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
4347
]
4448

49+
-- | Generate code lenses.
50+
codeLens
51+
:: LSP.LspFuncs ()
52+
-> IdeState
53+
-> CodeLensParams
54+
-> IO (List CodeLens)
55+
codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
56+
diag <- getDiagnostics ideState
57+
case uriToFilePath' uri of
58+
Just (toNormalizedFilePath -> filePath) -> do
59+
pure $ List
60+
[ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
61+
| (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag
62+
, dFile == filePath
63+
, (title, tedit) <- suggestTopLevelBinding False dDiag
64+
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
65+
]
66+
Nothing -> pure $ List []
67+
68+
-- | Generate code lenses.
69+
executeAddSignatureCommand
70+
:: LSP.LspFuncs ()
71+
-> IdeState
72+
-> ExecuteCommandParams
73+
-> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
74+
executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
75+
| _command == "typesignature.add"
76+
, Just (List [edit]) <- _arguments
77+
, Success wedit <- fromJSON edit
78+
= return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
79+
| otherwise
80+
= return (Null, Nothing)
4581

4682
suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
47-
suggestAction contents Diagnostic{_range=_range@Range{..},..}
83+
suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}
4884

4985
-- File.hs:16:1: warning:
5086
-- The import of `Data.List' is redundant
@@ -141,17 +177,22 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
141177
extractFitNames = map (T.strip . head . T.splitOn " :: ")
142178
in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
143179

180+
| tlb@[_] <- suggestTopLevelBinding True diag = tlb
181+
182+
suggestAction _ _ = []
183+
184+
suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
185+
suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}
144186
| "Top-level binding with no type signature" `T.isInfixOf` _message = let
145187
filterNewlines = T.concat . T.lines
146188
unifySpaces = T.unwords . T.words
147189
signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
148190
startOfLine = Position (_line _start) 0
149191
beforeLine = Range startOfLine startOfLine
150-
title = "add signature: " <> signature
192+
title = if isQuickFix then "add signature: " <> signature else signature
151193
action = TextEdit beforeLine $ signature <> "\n"
152194
in [(title, [action])]
153-
154-
suggestAction _ _ = []
195+
suggestTopLevelBinding _ _ = []
155196

156197
topOfHoleFitsMarker :: T.Text
157198
topOfHoleFitsMarker =
@@ -236,3 +277,9 @@ setHandlersCodeAction :: PartialHandlers
236277
setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
237278
LSP.codeActionHandler = withResponse RspCodeAction codeAction
238279
}
280+
281+
setHandlersCodeLens :: PartialHandlers
282+
setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
283+
LSP.codeLensHandler = withResponse RspCodeLens codeLens,
284+
LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
285+
}

‎src/Development/IDE/LSP/LanguageServer.hs

Lines changed: 45 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,9 @@ runLanguageServer options userHandlers getIdeState = do
7676
atomically $ modifyTVar pendingRequests (Set.insert _id)
7777
writeChan clientMsgChan $ Response r wrap f
7878
let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))
79+
let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
80+
atomically $ modifyTVar pendingRequests (Set.insert _id)
81+
writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
7982
let cancelRequest reqId = atomically $ do
8083
queued <- readTVar pendingRequests
8184
-- We want to avoid that the list of cancelled requests
@@ -93,13 +96,14 @@ runLanguageServer options userHandlers getIdeState = do
9396
unless (reqId `Set.member` cancelled) retry
9497
let PartialHandlers parts =
9598
setHandlersIgnore <> -- least important
96-
setHandlersDefinition <> setHandlersHover <> setHandlersCodeAction <> -- useful features someone may override
99+
setHandlersDefinition <> setHandlersHover <>
100+
setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
97101
userHandlers <>
98102
setHandlersNotifications <> -- absolutely critical, join them with user notifications
99103
cancelHandler cancelRequest
100104
-- Cancel requests are special since they need to be handled
101105
-- out of order to be useful. Existing handlers are run afterwards.
102-
handlers <- parts WithMessage{withResponse, withNotification} def
106+
handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
103107

104108
let initializeCallbacks = LSP.InitializeCallbacks
105109
{ LSP.onInitialConfiguration = const $ Right ()
@@ -131,30 +135,42 @@ runLanguageServer options userHandlers getIdeState = do
131135
"Message: " ++ show x ++ "\n" ++
132136
"Exception: " ++ show e
133137
Response x@RequestMessage{_id, _params} wrap act ->
134-
flip finally (clearReqId _id) $
135-
catch (do
136-
-- We could optimize this by first checking if the id
137-
-- is in the cancelled set. However, this is unlikely to be a
138-
-- bottleneck and the additional check might hide
139-
-- issues with async exceptions that need to be fixed.
140-
cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
141-
case cancelOrRes of
142-
Left () -> do
143-
logDebug (ideLogger ide) $ T.pack $
144-
"Cancelled request " <> show _id
145-
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
146-
Just $ ResponseError RequestCancelled "" Nothing
147-
Right res ->
148-
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
149-
) $ \(e :: SomeException) -> do
150-
logError (ideLogger ide) $ T.pack $
151-
"Unexpected exception on request, please report!\n" ++
152-
"Message: " ++ show x ++ "\n" ++
153-
"Exception: " ++ show e
154-
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
155-
Just $ ResponseError InternalError (T.pack $ show e) Nothing
138+
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
139+
\res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
140+
ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
141+
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
142+
\(res, newReq) -> do
143+
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
144+
case newReq of
145+
Nothing -> return ()
146+
Just (rm, newReqParams) -> do
147+
reqId <- getNextReqId
148+
sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
156149
pure Nothing
157150

151+
checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
152+
flip finally (clearReqId _id) $
153+
catch (do
154+
-- We could optimize this by first checking if the id
155+
-- is in the cancelled set. However, this is unlikely to be a
156+
-- bottleneck and the additional check might hide
157+
-- issues with async exceptions that need to be fixed.
158+
cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
159+
case cancelOrRes of
160+
Left () -> do
161+
logDebug (ideLogger ide) $ T.pack $
162+
"Cancelled request " <> show _id
163+
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
164+
Just $ ResponseError RequestCancelled "" Nothing
165+
Right res -> k res
166+
) $ \(e :: SomeException) -> do
167+
logError (ideLogger ide) $ T.pack $
168+
"Unexpected exception on request, please report!\n" ++
169+
"Message: " ++ show msg ++ "\n" ++
170+
"Exception: " ++ show e
171+
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
172+
Just $ ResponseError InternalError (T.pack $ show e) Nothing
173+
158174

159175
-- | Things that get sent to us, but we don't deal with.
160176
-- Set them to avoid a warning in VS Code output.
@@ -177,11 +193,16 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
177193
-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
178194
data Message
179195
= forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
196+
-- | Used for cases in which we need to send not only a response,
197+
-- but also an additional request to the client.
198+
-- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
199+
| forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
180200
| forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
181201

182202

183203
modifyOptions :: LSP.Options -> LSP.Options
184204
modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
205+
, LSP.executeCommandCommands = Just ["typesignature.add"]
185206
}
186207
where
187208
tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

‎src/Development/IDE/LSP/Server.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,12 @@ data WithMessage = WithMessage
2626
Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
2727
(LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
2828
Maybe (LSP.Handler (NotificationMessage m req))
29+
,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
30+
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
31+
(ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
32+
(RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
33+
(LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
34+
Maybe (LSP.Handler (RequestMessage m req resp))
2935
}
3036

3137
newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

‎test/exe/Main.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -66,7 +66,7 @@ initializeResponseTests = withResource acquire release tests where
6666
, chk "NO doc symbol" _documentSymbolProvider Nothing
6767
, chk "NO workspace symbol" _workspaceSymbolProvider Nothing
6868
, chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
69-
, chk "NO code lens" _codeLensProvider Nothing
69+
, chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
7070
, chk "NO doc formatting" _documentFormattingProvider Nothing
7171
, chk "NO doc range formatting"
7272
_documentRangeFormattingProvider Nothing
@@ -76,7 +76,7 @@ initializeResponseTests = withResource acquire release tests where
7676
, chk "NO doc link" _documentLinkProvider Nothing
7777
, chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
7878
, chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
79-
, chk "NO execute command" _executeCommandProvider Nothing
79+
, chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
8080
, chk "NO workspace" _workspace nothingWorkspace
8181
, chk "NO experimental" _experimental Nothing
8282
] where

0 commit comments

Comments
 (0)