Raise test coverage above 95%

R/type_hierarchy.R

@@ -335,7 +335,7 @@ detect_s3class <- function(scopes, token_text, document, uri) {
 
         xpath <- glue(
             "//expr[LEFT_ASSIGN or EQ_ASSIGN][
-        preceding-sibling::expr[count(*)=1]/SYMBOL[text() = '{token_quote}']]",
+        expr[1][count(*)=1]/SYMBOL[text() = '{token_quote}']]",
             token_quote = xml_single_quote(token_text)
         )
 

R/utils.R

@@ -127,13 +127,12 @@ path_from_uri <- function(uri) {
         # Windows: vscode-notebook-cell:/c:/Users/Username/Documents/Notebooks/MyNotebook.ipynb#MyCellId
         # Unix: vscode-notebook-cell:/home/username/Documents/Notebooks/MyNotebook.ipynb#MyCellId
         # WSL: vscode-notebook-cell://wsl+ubuntu-20.04/home/username/Documents/Notebooks/MyNotebook.ipynb#MyCellId
-        if (.Platform$OS.type == "windows") {
-            path <- sub("^vscode-notebook-cell:/(.+)#.*$", "\\1", uri)
-        } else {
-            path <- sub("^vscode-notebook-cell:(.+)#.*$", "\\1", uri)
-            if (startsWith(path, "//")) {
-                path <- sub("^//[^/]+(/.+)$", "\\1", path)
-            }
+        path <- sub("^vscode-notebook-cell:(.+)#.*$", "\\1", uri)
+        if (startsWith(path, "//")) {
+            path <- sub("^//[^/]+(/.+)$", "\\1", path)
+        } else if (.Platform$OS.type == "windows" &&
+                grepl("^/[[:alpha:]]:/", path)) {
+            path <- substring(path, 2L)
         }
     } else {
         return("")
@@ -584,13 +583,13 @@ get_help_rd <- function(hfile) {
 get_help <- function(hfile, format = c("html", "text")) {
     format <- match.arg(format)
 
-    rd <- get_help_rd(hfile)
     paths <- as.character(hfile)
 
     if (length(paths) == 0) {
         return(NULL)
     }
 
+    rd <- get_help_rd(hfile)
     pkgname <- basename(dirname(dirname(paths[[1]])))
 
     if (format == "html") {

R/workspace.R

@@ -346,9 +346,18 @@ Workspace <- R6::R6Class("Workspace",
             }
             globals <- new.env(parent = emptyenv())
             if (is_package(self$root)) {
-                source_dir <- file.path(self$root, "R")
+                source_dir <- normalizePath(
+                    file.path(self$root, "R"),
+                    winslash = "/",
+                    mustWork = FALSE
+                )
                 for (doc in self$documents$values()) {
-                    if (dirname(path_from_uri(doc$uri)) != source_dir) next
+                    document_dir <- normalizePath(
+                        dirname(path_from_uri(doc$uri)),
+                        winslash = "/",
+                        mustWork = FALSE
+                    )
+                    if (document_dir != source_dir) next
                     parse_data <- doc$parse_data
                     if (is.null(parse_data)) next
                     for (symbol in parse_data$nonfuncts) {

tests/testthat/test-cache.R

@@ -17,3 +17,20 @@ test_that("ByteLruCache does not retain an oversized value", {
     expect_false(cache$has("large"))
     expect_equal(cache$bytes(), 0)
 })
+
+test_that("ByteLruCache exposes safe collection operations", {
+    cache <- ByteLruCache$new(max_bytes = 10000, max_entries = 2L)
+    expect_equal(cache$get("missing", "fallback"), "fallback")
+    expect_null(cache$remove("missing"))
+
+    cache$set("first", 1L)
+    cache$set("second", 2L)
+    expect_equal(cache$size(), 2L)
+    expect_setequal(cache$keys(), c("first", "second"))
+    expect_true(cache$bytes() > 0)
+
+    cache$clear()
+    expect_equal(cache$size(), 0L)
+    expect_length(cache$keys(), 0L)
+    expect_equal(cache$bytes(), 0)
+})

tests/testthat/test-call-hierarchy.R

@@ -238,3 +238,91 @@ test_that("Call hierarchy outgoing calls works", {
         end = list(line = 2, character = 46)
     ))
 })
+
+legacy_call_hierarchy_fixture <- function() {
+    content <- c(
+        "target <- function() 1",
+        "caller <- function() { target(); target() }"
+    )
+    uri <- "file:///legacy-call-hierarchy.R"
+    document <- Document$new(uri, version = 1L, content = content)
+    parse_data <- parse_document(uri, content)
+    parse_data$xml_doc <- xml2::read_xml(parse_data$xml_data)
+    parse_data$reference_index <- NULL
+    document$update_parse_data(parse_data)
+
+    documents <- collections::dict()
+    documents$set(uri, document)
+    workspace <- new.env(parent = baseenv())
+    workspace$documents <- documents
+    workspace$get_parse_data <- function(request_uri) {
+        stopifnot(identical(request_uri, uri))
+        parse_data
+    }
+    workspace$get_definitions_for_uri <- function(request_uri) {
+        stopifnot(identical(request_uri, uri))
+        unname(parse_data$definitions)
+    }
+    workspace$get_definition <- function(...) NULL
+
+    list(
+        uri = uri,
+        document = document,
+        workspace = workspace,
+        definitions = parse_data$definitions
+    )
+}
+
+test_that("Call hierarchy falls back to XML for outgoing calls", {
+    fixture <- legacy_call_hierarchy_fixture()
+    definition <- fixture$definitions$caller
+    item <- list(
+        name = "caller",
+        uri = fixture$uri,
+        range = definition$range,
+        data = list(definition = list(
+            uri = fixture$uri,
+            range = definition$range
+        ))
+    )
+
+    reply <- call_hierarchy_outgoing_calls_reply(
+        1L, fixture$workspace, item
+    )
+
+    expect_length(reply$result, 1L)
+    expect_equal(reply$result[[1L]]$to$name, "target")
+    expect_equal(reply$result[[1L]]$to$uri, fixture$uri)
+    expect_length(reply$result[[1L]]$fromRanges, 2L)
+    expect_equal(
+        map_int(reply$result[[1L]]$fromRanges, c("start", "line")),
+        c(1L, 1L)
+    )
+})
+
+test_that("Call hierarchy falls back to XML for incoming calls", {
+    fixture <- legacy_call_hierarchy_fixture()
+    definition <- fixture$definitions$target
+    item <- list(
+        name = "target",
+        uri = fixture$uri,
+        range = definition$range,
+        data = list(definition = list(
+            uri = fixture$uri,
+            range = definition$range
+        ))
+    )
+
+    reply <- call_hierarchy_incoming_calls_reply(
+        1L, fixture$workspace, item
+    )
+
+    expect_length(reply$result, 1L)
+    expect_equal(reply$result[[1L]]$from$name, "caller")
+    expect_equal(reply$result[[1L]]$from$kind, SymbolKind$Function)
+    expect_length(reply$result[[1L]]$fromRanges, 2L)
+    expect_equal(
+        map_int(reply$result[[1L]]$fromRanges, c("start", "character")),
+        c(23L, 33L)
+    )
+})

tests/testthat/test-code-action.R

@@ -214,3 +214,137 @@ test_that("Code action capabilities and request interface are precise", {
   expect_identical(params$range, request_range)
   expect_null(params$position)
 })
+
+test_that("Direct fixes reject diagnostics that cannot be applied safely", {
+  diagnostic <- function(code, start = 0L, end = 1L, message = "", line = 0L,
+                         source = "lintr") {
+    list(
+      range = range(position(line, start), position(line, end)),
+      source = source,
+      code = code,
+      message = message
+    )
+  }
+
+  cases <- list(
+    list("x <- 1", diagnostic("assignment_linter", 2L, 4L)),
+    list("x + 1", diagnostic("infix_spaces_linter", 2L, 2L)),
+    list("f(x)", diagnostic("commas_linter")),
+    list(" x", diagnostic("indentation_linter", message = "Bad indentation")),
+    list("x %>% f()", diagnostic("pipe_consistency_linter", 2L, 5L,
+      "Use one consistent pipe")),
+    list("X", diagnostic("T_and_F_symbol_linter")),
+    list("x", diagnostic("trailing_whitespace_linter")),
+    list(c("", "x"), diagnostic("trailing_blank_lines_linter")),
+    list("x", diagnostic("semicolon_linter")),
+    list("x", diagnostic("spaces_left_parentheses_linter")),
+    list("if (x)", diagnostic("brace_linter", message =
+      "There should be a space before an opening curly brace.")),
+    list("x == 1", diagnostic("equals_na_linter", 0L, 6L)),
+    list("x", diagnostic("unknown_linter"))
+  )
+
+  for (case in cases) {
+    document <- Document$new("file:///invalid-fix.R", content = case[[1L]])
+    expect_null(code_action_direct_fix(document, case[[2L]]))
+  }
+
+  already_formatted <- Document$new("file:///no-op.R", content = "x + y")
+  expect_null(code_action_direct_fix(
+    already_formatted,
+    diagnostic("infix_spaces_linter", 1L, 4L)
+  ))
+  expect_equal(code_action_character("abc", -1L), "")
+  expect_equal(code_action_character("abc", 3L), "")
+  expect_null(code_action_nearest_character("abc", ",", 0L, 1L))
+})
+
+test_that("Code action helpers preserve multiline text and merge duplicates", {
+  document <- Document$new("file:///edits.R", content = c("abc", "def"))
+  edit <- text_edit(
+    range(position(0L, 1L), position(1L, 1L)),
+    "replacement"
+  )
+  expect_equal(code_action_edit_text(document, edit), "bc\nd")
+
+  diagnostic <- list(
+    range = range(position(0L, 1L), position(0L, 2L)),
+    source = "lintr",
+    code = "assignment_linter",
+    message = "Use <- for assignment."
+  )
+  assignment <- Document$new("file:///duplicate.R", content = "x=1")
+  fixes <- code_action_direct_fixes(
+    assignment,
+    list(diagnostic, diagnostic, within(diagnostic, source <- "another-tool"))
+  )
+  expect_length(fixes, 1L)
+  expect_length(fixes[[1L]]$diagnostics, 2L)
+  expect_identical(code_action_direct_fixes(assignment, list()), list())
+  expect_identical(code_action_non_overlapping_fixes(list()), list())
+})
+
+test_that("Nolint edits handle existing, blank, and trailing-space lines", {
+  document <- Document$new("file:///nolint-edges.R", content = c(
+    "x # nolint",
+    "y # nolint: first_linter.",
+    "   ",
+    "z   "
+  ))
+
+  expect_null(code_action_nolint_edit(document, 0L))
+  expect_null(code_action_nolint_edit(document, 0L, "new_linter"))
+  expect_equal(
+    code_action_nolint_edit(document, 1L)$newText,
+    "# nolint"
+  )
+  expect_null(code_action_nolint_edit(document, 1L, "first_linter"))
+  expect_equal(
+    code_action_nolint_edit(document, 1L, "second_linter")$newText,
+    ", second_linter"
+  )
+  expect_equal(
+    code_action_nolint_edit(document, 2L, "blank_linter")$newText,
+    "# nolint: blank_linter."
+  )
+  expect_equal(
+    code_action_nolint_edit(document, 3L)$newText,
+    " # nolint"
+  )
+})
+
+test_that("Code action filtering ignores unrelated or invalid diagnostics", {
+  uri <- "file:///filtered-actions.R"
+  document <- Document$new(uri, content = "x")
+  unrelated <- list(
+    range = range(position(0L, 0L), position(0L, 1L)),
+    source = "another-tool",
+    code = "some_rule",
+    message = "Not from lintr"
+  )
+  missing_code <- within(unrelated, {
+    source <- "lintr"
+    code <- NULL
+  })
+  invalid_row <- within(unrelated, {
+    source <- "lintr"
+    range <- range(position(10L, 0L), position(10L, 1L))
+  })
+
+  expect_identical(
+    code_action_suppression_actions(
+      uri, document, list(unrelated, missing_code)
+    ),
+    list()
+  )
+  expect_identical(
+    code_action_suppression_actions(uri, document, list(invalid_row)),
+    list()
+  )
+
+  reply <- document_code_action_reply(
+    1L, uri, NULL, document, list(),
+    list(diagnostics = NULL, only = list("quickfix"))
+  )
+  expect_identical(reply$result, list())
+})

tests/testthat/test-code-lens.R

@@ -66,3 +66,51 @@ test_that("code lenses work through the language server after incremental edits"
     )
     expect_equal(changed_lenses[[1L]]$data$symbol, "bar")
 })
+
+test_that("code lenses cover XML fallback and non-resolvable definitions", {
+    fixture <- provider_fixture(c(
+        "foo <- function(x) x",
+        "foo(1)",
+        "pkg::foo(2)",
+        "value <- 3"
+    ))
+    fixture$document$parse_data$reference_index <- NULL
+
+    locations <- function_call_locations(fixture$workspace, "foo")
+    expect_length(locations, 1L)
+    expect_equal(locations[[1L]]$range$start$line, 1L)
+
+    expect_length(function_call_locations(fixture$workspace, "absent"), 0L)
+    saved_xml <- fixture$document$parse_data$xml_doc
+    fixture$document$parse_data$xml_doc <- NULL
+    expect_length(function_call_locations(fixture$workspace, "foo"), 0L)
+    fixture$document$parse_data$xml_doc <- saved_xml
+
+    incomplete <- list(data = list(uri = fixture$uri))
+    expect_identical(
+        resolve_function_code_lens(fixture$workspace, incomplete),
+        incomplete
+    )
+
+    fixture$document$parse_data$definitions <- list()
+    empty <- code_lens_reply(
+        1L, fixture$uri, fixture$workspace, fixture$document)$result
+    expect_length(empty, 0L)
+
+    definition_range <- range(position(0L, 0L), position(0L, 5L))
+    fixture$document$parse_data$definitions <- list(
+        value = list(type = "double", range = definition_range),
+        foo = list(type = "function", range = definition_range)
+    )
+    eager <- code_lens_reply(
+        2L,
+        fixture$uri,
+        fixture$workspace,
+        fixture$document,
+        list(textDocument = list(codeLens = list(
+            resolveSupport = list(properties = "range")
+        )))
+    )$result
+    expect_length(eager, 1L)
+    expect_equal(eager[[1L]]$command$title, "1 call")
+})

tests/testthat/test-color.R

@@ -3,6 +3,27 @@ get_color <- function(color) {
     as.list(rgba[, 1])
 }
 
+test_that("color presentations preserve opaque and translucent alpha", {
+    fixture <- provider_fixture("value <- 1")
+    opaque <- color_presentation_reply(
+        1L,
+        fixture$uri,
+        fixture$workspace,
+        fixture$document,
+        list(red = 1, green = 0, blue = 0, alpha = 1)
+    )
+    translucent <- color_presentation_reply(
+        2L,
+        fixture$uri,
+        fixture$workspace,
+        fixture$document,
+        list(red = 1, green = 0, blue = 0, alpha = 0.5)
+    )
+
+    expect_equal(opaque$result[[1L]]$label, "#ff0000")
+    expect_equal(translucent$result[[1L]]$label, "#ff000080")
+})
+
 test_that("Document color works", {
     skip_on_cran()
     client <- language_client()