Add code action to disable linters

.github/workflows/rcmdcheck.yml

@@ -73,7 +73,7 @@ jobs:
       - name: Install a sperate copy on Windows
         if: runner.os == 'Windows'
         run: |
-          Rscript -e "remotes::install_local()"
+          Rscript -e "remotes::install_local(force = TRUE)"
       - name: Running Tests
         id: rcmdcheck
         run: |

R/capabilities.R

@@ -58,7 +58,7 @@ ServerCapabilities <- list(
     documentHighlightProvider = TRUE,
     documentSymbolProvider = TRUE,
     workspaceSymbolProvider = TRUE,
-    # codeActionProvider = FALSE,
+    codeActionProvider = TRUE,
     # codeLensProvider = CodeLensOptions,
     documentFormattingProvider = TRUE,
     documentRangeFormattingProvider = TRUE,

R/code_action.R

@@ -0,0 +1,59 @@
+CodeActionKind <- list(
+    Empty = "",
+    QuickFix = "quickfix",
+    Refactor = "refactor",
+    RefactorExtract = "refactor.extract",
+    RefactorInline = "refactor.inline",
+    RefactorRewrite = "refactor.rewrite",
+    Source = "source",
+    SourceOrganizeImports = "source.organizeImports"
+)
+
+#' The response to a textDocument/codeAction Request
+#'
+#' @keywords internal
+document_code_action_reply <- function(id, uri, workspace, document, range, context) {
+    result <- list()
+
+    for (item in context$diagnostics) {
+        item_range <- list(
+            start = document$from_lsp_position(item$range$start),
+            end = document$from_lsp_position(item$range$end)
+        )
+
+        if (item_range$start$row == item_range$end$row &&
+            item_range$start$col < item_range$end$col) {
+            position <- document$to_lsp_position(
+                item_range$end$row,
+                nchar(document$line(item_range$end$row + 1))
+            )
+            changes <- list(
+                list(
+                    text_edit(range = range(
+                        start = position,
+                        end = position
+                    ), " # nolint")
+                )
+            )
+            names(changes) <- uri
+            action <- list(
+                title = "Disable all linters for this line",
+                kind = CodeActionKind$QuickFix,
+                edit = list(
+                    changes = changes
+                )
+            )
+
+            result <- c(result, list(action))
+        }
+    }
+
+    logger$info("document_code_action_reply: ", list(
+        uri = uri,
+        range = range,
+        context = context,
+        result = result
+    ))
+
+    Response$new(id, result = result)
+}

R/diagnostics.R

@@ -115,13 +115,17 @@ diagnose_file <- function(uri, content, cache = FALSE) {
 
 diagnostics_callback <- function(self, uri, version, diagnostics) {
     if (is.null(diagnostics) || !self$workspace$documents$has(uri)) return(NULL)
-    logger$info("diagnostics_callback called:", list(uri = uri, version = version))
-    # logger$info("diagnostics:", diagnostics)
+    logger$info("diagnostics_callback called:", list(
+        uri = uri,
+        version = version,
+        diagnostics = diagnostics
+    ))
     self$deliver(
         Notification$new(
             method = "textDocument/publishDiagnostics",
             params = list(
                 uri = uri,
+                version = version,
                 diagnostics = diagnostics
             )
         )

R/handlers-langfeatures.R

@@ -127,7 +127,16 @@ text_document_document_symbol  <- function(self, id, params) {
 #' Handler to the `textDocument/codeAction` [Request].
 #' @noRd
 text_document_code_action  <- function(self, id, params) {
-
+    logger$info("text_document_code_action: ", params)
+    textDocument <- params$textDocument
+    uri <- uri_escape_unicode(textDocument$uri)
+    document <- self$workspace$documents$get(uri)
+    range <- list(
+        start = document$from_lsp_position(params$range$start),
+        end = document$from_lsp_position(params$range$end)
+    )
+    context <- params$context
+    self$deliver(document_code_action_reply(id, uri, self$workspace, document, range, context))
 }
 
 #' `textDocument/codeLens` request handler

R/languageserver.R

@@ -204,6 +204,7 @@ LanguageServer$set("public", "register_handlers", function() {
         `textDocument/documentLink` = text_document_document_link,
         `documentLink/resolve` = document_link_resolve,
         `textDocument/documentColor` = text_document_document_color,
+        `textDocument/codeAction` = text_document_code_action,
         `textDocument/colorPresentation` = text_document_color_presentation,
         `textDocument/foldingRange` = text_document_folding_range,
         `textDocument/references` = text_document_references,

R/utils.R

@@ -703,3 +703,24 @@ is_text_file <- function(path, n = 1000) {
     }
     return(FALSE)
 }
+
+compare_position <- function(position1, position2) {
+    if (position1$line < position2$line ||
+        (position1$line == position2$line &&
+            position1$character < position2$character)) {
+        -1L
+    } else if (position1$line > position2$line ||
+        (position1$line == position2$line &&
+            position1$character > position2$character)) {
+        1L
+    } else {
+        0L
+    }
+}
+
+range_overlap <- function(range1, range2) {
+    !(compare_position(range1$end, range2$start) < 0 ||
+        compare_position(range1$start, range2$end) > 0 ||
+        compare_position(range2$end, range1$start) < 0 ||
+        compare_position(range2$start, range1$end) > 0)
+}

README.md

@@ -87,7 +87,7 @@ These editors are supported by installing the corresponding package.
 - [x] [documentHighlightProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_documentHighlight)
 - [x] [documentSymbolProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_documentSymbol)
 - [x] [workspaceSymbolProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#workspace_symbol)
-- [ ] [codeActionProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_codeAction)
+- [x] [codeActionProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_codeAction)
 - [ ] [codeLensProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_codeLens)
 - [x] [documentFormattingProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_formatting)
 - [x] [documentRangeFormattingProvider](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_rangeFormatting)

tests/testthat/helper-utils.R

@@ -423,6 +423,29 @@ respond_call_hierarchy_outgoing_calls <- function(client, item, ...) {
     )
 }
 
+respond_code_action <- function(client, path, start_pos, end_pos, ...) {
+    uri <- path_to_uri(path)
+    diagnostics <- client$diagnostics$get(uri)
+    range <- range(
+        start = position(start_pos[1], start_pos[2]),
+        end = position(end_pos[1], end_pos[2])
+    )
+    respond(
+        client,
+        "textDocument/codeAction",
+        list(
+            textDocument = list(uri = uri),
+            range = range,
+            context = list(
+                diagnostics = Filter(function(item) {
+                    range_overlap(item$range, range)
+                }, diagnostics)
+            )
+        ),
+        ...
+    )
+}
+
 wait_for <- function(client, method, timeout = 30) {
     storage <- new.env(parent = .GlobalEnv)
     start_time <- Sys.time()

tests/testthat/test-code-action.R

@@ -0,0 +1,40 @@
+test_that("Code action works", {
+  skip_on_cran()
+
+  dir <- tempdir()
+  client <- language_client(working_dir = dir, diagnostics = TRUE)
+
+  temp_file <- withr::local_tempfile(tmpdir = dir, fileext = ".R")
+  writeLines(c(
+    "1+1",
+    "my_fun <- function(x) {",
+    "  x+1",
+    "}"
+  ), temp_file)
+
+  client %>% did_open(temp_file)
+  data <- client %>% wait_for("textDocument/publishDiagnostics")
+
+  expect_equal(client$diagnostics$size(), 1)
+  expect_equal(client$diagnostics$get(data$uri), data$diagnostics)
+  expect_equal(data$diagnostics[[1]]$source, "infix_spaces_linter")
+  expect_equal(data$diagnostics[[1]]$message, "Put spaces around all infix operators.")
+  expect_equal(data$diagnostics[[2]]$source, "infix_spaces_linter")
+  expect_equal(data$diagnostics[[2]]$message, "Put spaces around all infix operators.")
+
+  result <- client %>% respond_code_action(temp_file, c(0, 0), c(0, 1))
+  expect_length(result, 1)
+  expect_equal(result[[1]]$title, "Disable all linters for this line")
+
+  result <- client %>% respond_code_action(temp_file, c(1, 0), c(1, 5), retry = FALSE)
+  expect_length(result, 0)
+
+  result <- client %>% respond_code_action(temp_file, c(2, 3), c(2, 4))
+  expect_length(result, 1)
+  expect_equal(result[[1]]$title, "Disable all linters for this line")
+
+  result <- client %>% respond_code_action(temp_file, c(0, 0), c(3, 0))
+  expect_length(result, 2)
+  expect_equal(result[[1]]$title, "Disable all linters for this line")
+  expect_equal(result[[2]]$title, "Disable all linters for this line")
+})