diff --git a/src/Development/IDE/LSP/CodeAction.hs b/src/Development/IDE/LSP/CodeAction.hs index 809141b16..0ffed42a5 100644 --- a/src/Development/IDE/LSP/CodeAction.hs +++ b/src/Development/IDE/LSP/CodeAction.hs @@ -8,18 +8,22 @@ -- | Go to the definition of a variable. module Development.IDE.LSP.CodeAction ( setHandlersCodeAction + , setHandlersCodeLens ) where import Language.Haskell.LSP.Types import Development.IDE.GHC.Compat import Development.IDE.Core.Rules +import Development.IDE.Core.Shake import Development.IDE.LSP.Server +import Development.IDE.Types.Location import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Messages import qualified Data.Rope.UTF16 as Rope +import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) import Data.Char import Data.Maybe import Data.List.Extra @@ -42,9 +46,41 @@ codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_cont , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] +-- | Generate code lenses. +codeLens + :: LSP.LspFuncs () + -> IdeState + -> CodeLensParams + -> IO (List CodeLens) +codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + diag <- getDiagnostics ideState + case uriToFilePath' uri of + Just (toNormalizedFilePath -> filePath) -> do + pure $ List + [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing + | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag + , dFile == filePath + , (title, tedit) <- suggestTopLevelBinding False dDiag + , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + ] + Nothing -> pure $ List [] + +-- | Generate code lenses. +executeAddSignatureCommand + :: LSP.LspFuncs () + -> IdeState + -> ExecuteCommandParams + -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} + | _command == "typesignature.add" + , Just (List [edit]) <- _arguments + , Success wedit <- fromJSON edit + = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) + | otherwise + = return (Null, Nothing) suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction contents Diagnostic{_range=_range@Range{..},..} +suggestAction contents diag@Diagnostic{_range=_range@Range{..},..} -- File.hs:16:1: warning: -- The import of `Data.List' is redundant @@ -141,17 +177,22 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..} extractFitNames = map (T.strip . head . T.splitOn " :: ") in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message + | tlb@[_] <- suggestTopLevelBinding True diag = tlb + +suggestAction _ _ = [] + +suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] +suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..} | "Top-level binding with no type signature" `T.isInfixOf` _message = let filterNewlines = T.concat . T.lines unifySpaces = T.unwords . T.words signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message startOfLine = Position (_line _start) 0 beforeLine = Range startOfLine startOfLine - title = "add signature: " <> signature + title = if isQuickFix then "add signature: " <> signature else signature action = TextEdit beforeLine $ signature <> "\n" in [(title, [action])] - -suggestAction _ _ = [] +suggestTopLevelBinding _ _ = [] topOfHoleFitsMarker :: T.Text topOfHoleFitsMarker = @@ -236,3 +277,9 @@ setHandlersCodeAction :: PartialHandlers setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.codeActionHandler = withResponse RspCodeAction codeAction } + +setHandlersCodeLens :: PartialHandlers +setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.codeLensHandler = withResponse RspCodeLens codeLens, + LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand + } diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index 134410d09..831025a48 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -76,6 +76,9 @@ runLanguageServer options userHandlers getIdeState = do atomically $ modifyTVar pendingRequests (Set.insert _id) writeChan clientMsgChan $ Response r wrap f let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r)) + let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do + atomically $ modifyTVar pendingRequests (Set.insert _id) + writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f let cancelRequest reqId = atomically $ do queued <- readTVar pendingRequests -- We want to avoid that the list of cancelled requests @@ -93,13 +96,14 @@ runLanguageServer options userHandlers getIdeState = do unless (reqId `Set.member` cancelled) retry let PartialHandlers parts = setHandlersIgnore <> -- least important - setHandlersDefinition <> setHandlersHover <> setHandlersCodeAction <> -- useful features someone may override + setHandlersDefinition <> setHandlersHover <> + setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override userHandlers <> setHandlersNotifications <> -- absolutely critical, join them with user notifications cancelHandler cancelRequest -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - handlers <- parts WithMessage{withResponse, withNotification} def + handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def let initializeCallbacks = LSP.InitializeCallbacks { LSP.onInitialConfiguration = const $ Right () @@ -131,30 +135,42 @@ runLanguageServer options userHandlers getIdeState = do "Message: " ++ show x ++ "\n" ++ "Exception: " ++ show e Response x@RequestMessage{_id, _params} wrap act -> - flip finally (clearReqId _id) $ - catch (do - -- We could optimize this by first checking if the id - -- is in the cancelled set. However, this is unlikely to be a - -- bottleneck and the additional check might hide - -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params - case cancelOrRes of - Left () -> do - logDebug (ideLogger ide) $ T.pack $ - "Cancelled request " <> show _id - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ - Just $ ResponseError RequestCancelled "" Nothing - Right res -> - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing - ) $ \(e :: SomeException) -> do - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on request, please report!\n" ++ - "Message: " ++ show x ++ "\n" ++ - "Exception: " ++ show e - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ - Just $ ResponseError InternalError (T.pack $ show e) Nothing + checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ + \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing + ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act -> + checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ + \(res, newReq) -> do + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing + case newReq of + Nothing -> return () + Just (rm, newReqParams) -> do + reqId <- getNextReqId + sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams pure Nothing + checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k = + flip finally (clearReqId _id) $ + catch (do + -- We could optimize this by first checking if the id + -- is in the cancelled set. However, this is unlikely to be a + -- bottleneck and the additional check might hide + -- issues with async exceptions that need to be fixed. + cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params + case cancelOrRes of + Left () -> do + logDebug (ideLogger ide) $ T.pack $ + "Cancelled request " <> show _id + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ + Just $ ResponseError RequestCancelled "" Nothing + Right res -> k res + ) $ \(e :: SomeException) -> do + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on request, please report!\n" ++ + "Message: " ++ show msg ++ "\n" ++ + "Exception: " ++ show e + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ + Just $ ResponseError InternalError (T.pack $ show e) Nothing + -- | Things that get sent to us, but we don't deal with. -- Set them to avoid a warning in VS Code output. @@ -177,11 +193,16 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x -- 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) + -- | 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. + | 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))) | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ()) modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS + , LSP.executeCommandCommands = Just ["typesignature.add"] } where tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing} diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs index 180392ec3..e04dc491f 100644 --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -26,6 +26,12 @@ data WithMessage = WithMessage 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. + (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 + (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work + Maybe (LSP.Handler (RequestMessage m req resp)) } newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers) diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 2a52302d9..c9b0ec2fa 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -66,7 +66,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO doc symbol" _documentSymbolProvider Nothing , chk "NO workspace symbol" _workspaceSymbolProvider Nothing , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True - , chk "NO code lens" _codeLensProvider Nothing + , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing , chk "NO doc formatting" _documentFormattingProvider Nothing , chk "NO doc range formatting" _documentRangeFormattingProvider Nothing @@ -76,7 +76,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) - , chk "NO execute command" _executeCommandProvider Nothing + , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"]) , chk "NO workspace" _workspace nothingWorkspace , chk "NO experimental" _experimental Nothing ] where