diff --git a/R/type_hierarchy.R b/R/type_hierarchy.R
index d80cfdf1..e557c539 100644
--- a/R/type_hierarchy.R
+++ b/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)
)
diff --git a/R/utils.R b/R/utils.R
index fe68a53e..dfa28f1f 100644
--- a/R/utils.R
+++ b/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") {
diff --git a/R/workspace.R b/R/workspace.R
index ac476c3c..c98af349 100644
--- a/R/workspace.R
+++ b/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) {
diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R
index c3825d9c..3eec3e50 100644
--- a/tests/testthat/test-cache.R
+++ b/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)
+})
diff --git a/tests/testthat/test-call-hierarchy.R b/tests/testthat/test-call-hierarchy.R
index 65991e57..b2ddc91f 100644
--- a/tests/testthat/test-call-hierarchy.R
+++ b/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)
+ )
+})
diff --git a/tests/testthat/test-code-action.R b/tests/testthat/test-code-action.R
index b6dcfd02..737e7f4f 100644
--- a/tests/testthat/test-code-action.R
+++ b/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())
+})
diff --git a/tests/testthat/test-code-lens.R b/tests/testthat/test-code-lens.R
index f1287056..d6cc0058 100644
--- a/tests/testthat/test-code-lens.R
+++ b/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")
+})
diff --git a/tests/testthat/test-color.R b/tests/testthat/test-color.R
index 6a094de9..d50bbbcf 100644
--- a/tests/testthat/test-color.R
+++ b/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()
diff --git a/tests/testthat/test-completion.R b/tests/testthat/test-completion.R
index c0bda7d1..835a0329 100644
--- a/tests/testthat/test-completion.R
+++ b/tests/testthat/test-completion.R
@@ -1481,3 +1481,202 @@ test_that("Completion parse index handles supported symbol forms", {
c("argument", "lambda_argument"))
expect_setequal(parse_data$empty_tokens, c("member", "named"))
})
+
+completion_test_namespace <- function(name, functions = character(),
+ values = character(), lazydata = character()) {
+ namespace <- new.env(parent = baseenv())
+ namespace$package_name <- name
+ namespace$get_symbols <- function(want_functs, exported_only = TRUE) {
+ if (want_functs) functions else values
+ }
+ namespace$get_lazydata <- function() lazydata
+ namespace$exists_funct <- function(object) object %in% functions
+ namespace
+}
+
+test_that("Namespace completions distinguish workspace and package functions", {
+ package <- completion_test_namespace(
+ "example", functions = c("alpha", "beta")
+ )
+ workspace <- completion_test_namespace(
+ WORKSPACE, functions = "alpha_workspace"
+ )
+
+ package_items <- ns_function_completion(package, "al", TRUE, TRUE)
+ expect_length(package_items, 1L)
+ expect_equal(package_items[[1L]]$detail, "{example}")
+ expect_equal(package_items[[1L]]$insertText, "alpha($0)")
+ expect_equal(package_items[[1L]]$insertTextFormat, InsertTextFormat$Snippet)
+
+ workspace_items <- ns_function_completion(
+ workspace, "workspace", TRUE, FALSE
+ )
+ expect_length(workspace_items, 1L)
+ expect_equal(workspace_items[[1L]]$detail, "[workspace]")
+ expect_null(workspace_items[[1L]]$insertText)
+})
+
+test_that("Imported completions skip missing and non-function namespaces", {
+ imports <- collections::dict()
+ imports$set("alpha", "example")
+ imports$set("value", "example")
+ imports$set("missing", "missing-package")
+ namespace <- completion_test_namespace(
+ "example", functions = "alpha", values = "value"
+ )
+ workspace <- new.env(parent = baseenv())
+ workspace$imported_objects <- imports
+ workspace$get_namespace <- function(name) {
+ if (identical(name, "example")) namespace else NULL
+ }
+
+ items <- imported_object_completion(workspace, "a", TRUE)
+ expect_length(items, 1L)
+ expect_equal(items[[1L]]$label, "alpha")
+ expect_equal(items[[1L]]$insertText, "alpha($0)")
+
+ plain <- imported_object_completion(workspace, "alpha", FALSE)
+ expect_null(plain[[1L]]$insertText)
+ expect_null(imported_object_completion(workspace, "unmatched", TRUE))
+})
+
+test_that("Workspace completion combines namespaces, imports, and limits", {
+ imports <- collections::dict()
+ imports$set("imported_fun", "example")
+ global <- completion_test_namespace(
+ WORKSPACE,
+ functions = c("global_fun", "global_other"),
+ values = "global_value"
+ )
+ package <- completion_test_namespace(
+ "example",
+ functions = c("exported_fun", "imported_fun"),
+ values = "exported_value",
+ lazydata = "example_data"
+ )
+ workspace <- new.env(parent = baseenv())
+ workspace$loaded_packages <- "example"
+ workspace$imported_objects <- imports
+ workspace$get_namespace <- function(name) {
+ if (identical(name, WORKSPACE)) global else if (identical(name, "example")) package
+ }
+
+ items <- workspace_completion(
+ workspace, "", snippet_support = TRUE, limit = 4L
+ )
+ expect_length(items, 4L)
+ expect_true(isTRUE(attr(items, "truncated")))
+ expect_true(all(vapply(items, function(item) {
+ !is.null(item$label) && !is.null(item$data$type)
+ }, logical(1L))))
+
+ private_items <- workspace_completion(
+ workspace, "exported", package = "example",
+ exported_only = FALSE, snippet_support = FALSE
+ )
+ expect_setequal(
+ vapply(private_items, `[[`, character(1L), "label"),
+ c("exported_fun", "exported_value")
+ )
+ expect_identical(
+ workspace_completion(
+ workspace, "nothing-matches", package = "example"
+ ),
+ list()
+ )
+})
+
+test_that("Argument value completion accepts only literal character defaults", {
+ defaults <- quote(c("first", I("second"), 3, identity("ignored")))
+ expect_identical(extract_default_values(defaults), c("first", "second"))
+ expect_identical(extract_default_values("single"), "single")
+ expect_null(extract_default_values(quote(c(1, 2))))
+ missing_default <- alist(value = )[[1L]]
+ expect_null(extract_default_values(missing_default))
+
+ workspace <- new.env(parent = baseenv())
+ workspace$get_formals <- function(...) alist(
+ mode = c("auto", "manual"),
+ count = 1L
+ )
+ expect_identical(
+ argument_value_completion(
+ workspace, "fun", NULL, "missing", "", formals_list = list()
+ ),
+ list()
+ )
+ items <- argument_value_completion(
+ workspace, "fun", NULL, "mode", "man"
+ )
+ expect_length(items, 1L)
+ expect_equal(items[[1L]]$label, "manual")
+ expect_equal(items[[1L]]$insertText, '"manual"')
+})
+
+test_that("Indexed and XML scope completions agree on local symbols", {
+ content <- c(
+ "outer <- function(argument) {",
+ " local_value <- 1",
+ " local_fun <- function() local_value",
+ " local_value",
+ "}"
+ )
+ fixture <- provider_fixture(content)
+ point <- list(row = 3L, col = 8L)
+
+ indexed <- scope_completion(
+ fixture$uri, fixture$workspace, "local_", point,
+ snippet_support = TRUE
+ )
+ expect_length(indexed, 2L)
+
+ limited <- scope_completion(
+ fixture$uri, fixture$workspace, "local_", point,
+ snippet_support = TRUE, limit = 1L
+ )
+ expect_length(limited, 1L)
+ expect_true(isTRUE(attr(limited, "truncated")))
+
+ parse_data <- fixture$document$parse_data
+ parse_data$completion_data <- NULL
+ legacy_workspace <- new.env(parent = baseenv())
+ legacy_workspace$get_parse_data <- function(...) parse_data
+ legacy <- scope_completion(
+ fixture$uri, legacy_workspace, "local_", point,
+ snippet_support = FALSE
+ )
+ expect_setequal(
+ vapply(legacy, `[[`, character(1L), "label"),
+ vapply(indexed, `[[`, character(1L), "label")
+ )
+
+ parse_data$xml_doc <- NULL
+ expect_identical(
+ scope_completion(fixture$uri, legacy_workspace, "x", point),
+ list()
+ )
+})
+
+test_that("Token completion supports indexed and XML parse data", {
+ content <- c("object$member", "target(named = 1)", "member_other <- 2")
+ fixture <- provider_fixture(content)
+
+ indexed <- token_completion(
+ fixture$uri, fixture$workspace, "mem", exclude = "member_other",
+ limit = 1L
+ )
+ expect_length(indexed, 1L)
+ expect_equal(indexed[[1L]]$label, "member")
+
+ parse_data <- fixture$document$parse_data
+ parse_data$completion_data <- NULL
+ legacy_workspace <- list(get_parse_data = function(...) parse_data)
+ legacy <- token_completion(fixture$uri, legacy_workspace, "mem")
+ expect_true("member" %in% vapply(legacy, `[[`, character(1L), "label"))
+
+ parse_data$xml_doc <- NULL
+ expect_identical(
+ token_completion(fixture$uri, legacy_workspace, "mem"),
+ list()
+ )
+})
diff --git a/tests/testthat/test-document-core.R b/tests/testthat/test-document-core.R
new file mode 100644
index 00000000..05e3a363
--- /dev/null
+++ b/tests/testthat/test-document-core.R
@@ -0,0 +1,62 @@
+test_that("Document changes handle whole files and multiline replacements", {
+ uri <- "file:///document-core.R"
+ document <- Document$new(uri, version = 1L, content = c("one", "two", "three"))
+
+ document$apply_content_changes(2L, list(list(text = "replacement")))
+ expect_identical(document$content, "replacement")
+ expect_equal(document$version, 2L)
+
+ document$set_content(2L, c("one", "two", "three"))
+ document$apply_content_changes(3L, list(list(
+ range = range(position(1L, 1L), position(1L, 2L)),
+ text = "A\nB\nC"
+ )))
+ expect_identical(document$content, c("one", "tA", "B", "Co", "three"))
+ expect_equal(document$line(99L), "")
+ expect_equal(
+ document$detect_call(list(row = 0L, col = 0L)),
+ list(token = "")
+ )
+
+ expect_null(null_function())
+ expect_identical(normalize_parse_content(character()), "")
+})
+
+test_that("Parse callbacks discard stale work and superseded replies", {
+ uri <- "file:///parse-callback.R"
+ document <- Document$new(uri, version = 2L, content = "value <- 1")
+ previous <- parse_document(uri, document$content)
+ previous$version <- document$version
+ document$update_parse_data(previous)
+ workspace <- Workspace$new(NULL)
+ workspace$documents$set(uri, document)
+
+ self <- new.env(parent = baseenv())
+ self$get_workspace <- function(...) workspace
+ self$pending_replies <- collections::dict()
+ self$request_handlers <- list(test = function(...) stop("not expected"))
+ self$deliveries <- list()
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ }
+
+ expect_null(parse_callback(self, uri, 2L, NULL))
+ expect_null(parse_callback(self, uri, 1L, parse_document(uri, "value <- 0")))
+
+ queue <- collections::queue()
+ queue$push(list(id = 1L, version = 1L, params = list()))
+ queue$push(list(id = 2L, version = 3L, params = list()))
+ self$pending_replies$set(uri, list(test = queue))
+ current <- parse_document(uri, document$content)
+ parse_callback(self, uri, 2L, current)
+
+ expect_length(self$deliveries, 1L)
+ expect_equal(self$deliveries[[1L]]$id, 1L)
+ expect_equal(self$deliveries[[1L]]$error$code, ErrorCodes$RequestCancelled)
+ expect_equal(queue$size(), 1L)
+ expect_equal(queue$peek()$id, 2L)
+
+ missing_workspace <- Workspace$new(NULL)
+ self$get_workspace <- function(...) missing_workspace
+ expect_null(resolve_callback(self, uri, 2L, character()))
+})
diff --git a/tests/testthat/test-formatting.R b/tests/testthat/test-formatting.R
index d1ed8f49..53c3cc4a 100644
--- a/tests/testthat/test-formatting.R
+++ b/tests/testthat/test-formatting.R
@@ -316,3 +316,156 @@ test_that("On type formatting works in Rmarkdown", {
"}"
))
})
+
+test_that("Formatting helpers handle invalid and synthesized source", {
+ withr::local_options(languageserver.formatting_style = NULL)
+ options <- list(tabSize = 2L, insertSpaces = TRUE)
+
+ expect_null(style_text("x <-", get_style(options)))
+ expect_equal(missing_closing_delimiters(character()), "")
+ expect_equal(missing_closing_delimiters(c("foo(", "bar[")), "])")
+ expect_equal(missing_closing_delimiters("value <- 1"), "")
+ expect_null(complete_incomplete_expression(" "))
+ expect_null(complete_incomplete_expression("value <- 1"))
+
+ completed <- complete_incomplete_expression(c(
+ "foo(", ".__languageserver_formatting_sentinel__ = 1,"
+ ))
+ expect_false(is.null(completed))
+ expect_match(completed$sentinel, "sentinel__+", perl = TRUE)
+ expect_equal(remove_formatting_sentinel(
+ paste0("prefix", completed$sentinel), completed$sentinel
+ ), "prefix")
+ expect_null(remove_formatting_sentinel("without sentinel", "missing"))
+ expect_null(remove_formatting_sentinel("marker marker", "marker"))
+
+ called <- FALSE
+ withr::local_options(languageserver.formatting_style = function(options) {
+ called <<- TRUE
+ styler::tidyverse_style(indent_by = options$tabSize * 2L)
+ })
+ expect_type(get_style(options), "list")
+ expect_true(called)
+})
+
+test_that("Formatting handles empty R Markdown and invalid blocks", {
+ options <- list(tabSize = 2L, insertSpaces = TRUE)
+ plain <- Document$new(
+ "file:///plain.Rmd", language = "rmd", content = "plain prose"
+ )
+ expect_identical(
+ formatting_reply(1L, plain$uri, plain, options)$result,
+ list()
+ )
+
+ invalid <- Document$new(
+ "file:///invalid.Rmd", language = "rmd",
+ content = c("```{r}", "x <-", "```")
+ )
+ reply <- formatting_reply(1L, invalid$uri, invalid, options)
+ expect_length(reply$result, 1L)
+ expect_equal(reply$result[[1L]]$newText, "x <-")
+})
+
+test_that("Range formatting handles empty and line-ending selections", {
+ options <- list(tabSize = 2L, insertSpaces = TRUE)
+ document <- Document$new(
+ "file:///ranges.R", language = "r",
+ content = c("x<-1", "y<-2", "z<-3")
+ )
+
+ empty <- range_formatting_reply(
+ 1L, document$uri, document,
+ list(start = list(row = 0L, col = 2L),
+ end = list(row = 0L, col = 2L)),
+ options
+ )
+ expect_identical(empty$result, list())
+
+ full_line <- range_formatting_reply(
+ 1L, document$uri, document,
+ list(start = list(row = 0L, col = 0L),
+ end = list(row = 1L, col = 0L)),
+ options
+ )
+ expect_length(full_line$result, 1L)
+ expect_equal(full_line$result[[1L]]$newText, "x <- 1")
+
+ merged <- ranges_formatting_reply(
+ 1L, document$uri, document,
+ list(
+ list(start = list(row = 1L, col = 0L),
+ end = list(row = 2L, col = 0L)),
+ list(start = list(row = 0L, col = 0L),
+ end = list(row = 1L, col = 4L))
+ ),
+ options
+ )
+ expect_length(merged$result, 1L)
+ expect_equal(merged$result[[1L]]$newText, "x <- 1\ny <- 2")
+ expect_identical(
+ ranges_formatting_reply(
+ 1L, document$uri, document, list(), options
+ )$result,
+ list()
+ )
+})
+
+test_that("Indentation fallback handles tabs, invalid points, and blank context", {
+ options <- list(tabSize = NA_integer_, insertSpaces = FALSE)
+ document <- Document$new(
+ "file:///indent.R", language = "r",
+ content = c("if (TRUE) {", "", " ", "value <- 1")
+ )
+
+ expect_null(indentation_only_reply(
+ 1L, document, list(row = -1L, col = 0L), options
+ )$result)
+ expect_null(indentation_only_reply(
+ 1L, document, list(row = 3L, col = 0L), options
+ )$result)
+
+ nested <- indentation_only_reply(
+ 1L, document, list(row = 1L, col = 0L), options
+ )
+ expect_equal(nested$result[[1L]]$newText, "\t")
+
+ previous <- Document$new(
+ "file:///previous.R", language = "r",
+ content = c(" value +", "", "")
+ )
+ spaced <- indentation_only_reply(
+ 1L, previous, list(row = 2L, col = 0L),
+ list(tabSize = 2L, insertSpaces = TRUE)
+ )
+ expect_equal(spaced$result[[1L]]$newText, " ")
+
+ blank <- Document$new("file:///blank.R", language = "r", content = "")
+ expect_null(indentation_only_reply(
+ 1L, blank, list(row = 0L, col = 0L), options
+ )$result)
+})
+
+test_that("On-type formatting ignores out-of-scope and leading newlines", {
+ options <- list(tabSize = 2L, insertSpaces = TRUE)
+ markdown <- Document$new(
+ "file:///scope.Rmd", language = "rmd",
+ content = c("prose", "", "```{r}", "x <- 1", "```")
+ )
+ expect_null(on_type_formatting_reply(
+ 1L, markdown$uri, markdown, list(row = 0L, col = 5L),
+ "\n", options
+ )$result)
+
+ document <- Document$new(
+ "file:///leading.R", language = "r", content = c("", "# comment")
+ )
+ expect_null(on_type_formatting_reply(
+ 1L, document$uri, document, list(row = 0L, col = 0L),
+ "\n", options
+ )$result)
+ expect_null(on_type_formatting_reply(
+ 1L, document$uri, document, list(row = 1L, col = 9L),
+ "\n", options
+ )$result)
+})
diff --git a/tests/testthat/test-handlers-langfeatures.R b/tests/testthat/test-handlers-langfeatures.R
new file mode 100644
index 00000000..b451a8a9
--- /dev/null
+++ b/tests/testthat/test-handlers-langfeatures.R
@@ -0,0 +1,261 @@
+langfeature_handler_fixture <- function(content = "value <- 1") {
+ fixture <- provider_fixture(content)
+ self <- new.env(parent = baseenv())
+ self$deliveries <- list()
+ self$get_workspace <- function(...) fixture$workspace
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ invisible(message)
+ }
+ self$rootPath <- tempdir()
+ self$ClientCapabilities <- list(textDocument = list(
+ completion = list(),
+ documentSymbol = list(),
+ codeLens = list()
+ ))
+ self$pending_replies <- collections::dict()
+ self$pending_replies$set(fixture$uri, list(
+ `textDocument/documentSymbol` = collections::queue(),
+ `textDocument/codeLens` = collections::queue(),
+ `textDocument/documentLink` = collections::queue(),
+ `textDocument/documentColor` = collections::queue(),
+ `textDocument/foldingRange` = collections::queue(),
+ `textDocument/linkedEditingRange` = collections::queue(),
+ `textDocument/inlineValue` = collections::queue(),
+ `textDocument/inlayHint` = collections::queue(),
+ `textDocument/semanticTokens/full` = collections::queue(),
+ `textDocument/semanticTokens/full/delta` = collections::queue(),
+ `textDocument/semanticTokens/range` = collections::queue()
+ ))
+ c(fixture, list(self = self))
+}
+
+test_that("language feature handlers deliver successful provider replies", {
+ fixture <- langfeature_handler_fixture()
+ point <- list(line = 0L, character = 0L)
+ request_range <- list(start = point, end = point)
+ params <- list(
+ textDocument = list(uri = fixture$uri),
+ position = point,
+ positions = list(point),
+ range = request_range,
+ ranges = list(request_range, request_range),
+ context = list(diagnostics = list()),
+ color = list(red = 1, green = 0, blue = 0, alpha = 1),
+ options = list(tabSize = 2L, insertSpaces = TRUE),
+ ch = ")",
+ newName = "renamed",
+ previousResultId = "previous"
+ )
+ cases <- list(
+ list(text_document_completion, "completion_reply"),
+ list(text_document_hover, "hover_reply"),
+ list(text_document_signature_help, "signature_reply"),
+ list(text_document_definition, "definition_reply"),
+ list(text_document_references, "references_reply"),
+ list(text_document_document_highlight, "document_highlight_reply"),
+ list(text_document_document_symbol, "document_symbol_reply"),
+ list(text_document_code_action, "document_code_action_reply"),
+ list(text_document_code_lens, "code_lens_reply"),
+ list(text_document_document_link, "document_link_reply"),
+ list(text_document_document_color, "document_color_reply"),
+ list(text_document_color_presentation, "color_presentation_reply"),
+ list(text_document_formatting, "formatting_reply"),
+ list(text_document_range_formatting, "range_formatting_reply"),
+ list(text_document_ranges_formatting, "ranges_formatting_reply"),
+ list(text_document_on_type_formatting, "on_type_formatting_reply"),
+ list(text_document_rename, "rename_reply"),
+ list(text_document_prepare_rename, "prepare_rename_reply"),
+ list(text_document_folding_range, "document_folding_range_reply"),
+ list(text_document_selection_range, "selection_range_reply"),
+ list(text_document_prepare_call_hierarchy, "prepare_call_hierarchy_reply"),
+ list(text_document_prepare_type_hierarchy, "prepare_type_hierarchy_reply"),
+ list(text_document_linked_editing_range, "linked_editing_range_reply"),
+ list(text_document_inline_value, "inline_value_reply"),
+ list(text_document_inlay_hint, "inlay_hint_reply"),
+ list(text_document_semantic_tokens_full, "semantic_tokens_full_reply"),
+ list(text_document_semantic_tokens_delta, "semantic_tokens_delta_reply"),
+ list(text_document_semantic_tokens_range, "semantic_tokens_range_reply")
+ )
+
+ for (case in cases) {
+ handler <- case[[1L]]
+ stub(handler, case[[2L]], function(id, ...) {
+ Response$new(id = id, result = list(provider = case[[2L]]))
+ })
+ before <- length(fixture$self$deliveries)
+ handler(fixture$self, before + 1L, params)
+ expect_length(fixture$self$deliveries, before + 1L)
+ expect_null(fixture$self$deliveries[[before + 1L]]$error)
+ }
+})
+
+test_that("language feature handlers return null for unknown documents", {
+ fixture <- langfeature_handler_fixture()
+ fixture$workspace$documents <- list(get = function(...) NULL)
+ point <- list(line = 0L, character = 0L)
+ request_range <- list(start = point, end = point)
+ params <- list(
+ textDocument = list(uri = fixture$uri),
+ position = point,
+ positions = list(point),
+ range = request_range,
+ ranges = list(request_range),
+ context = list(diagnostics = list()),
+ color = list(red = 1, green = 0, blue = 0, alpha = 1),
+ options = list(tabSize = 2L, insertSpaces = TRUE),
+ ch = ")",
+ newName = "renamed",
+ previousResultId = "previous"
+ )
+ handlers <- list(
+ text_document_completion,
+ text_document_hover,
+ text_document_signature_help,
+ text_document_definition,
+ text_document_references,
+ text_document_document_highlight,
+ text_document_document_symbol,
+ text_document_code_action,
+ text_document_code_lens,
+ text_document_document_link,
+ text_document_document_color,
+ text_document_color_presentation,
+ text_document_formatting,
+ text_document_range_formatting,
+ text_document_ranges_formatting,
+ text_document_on_type_formatting,
+ text_document_rename,
+ text_document_prepare_rename,
+ text_document_folding_range,
+ text_document_selection_range,
+ text_document_prepare_call_hierarchy,
+ text_document_prepare_type_hierarchy,
+ text_document_linked_editing_range,
+ text_document_inline_value,
+ text_document_inlay_hint,
+ text_document_semantic_tokens_full,
+ text_document_semantic_tokens_delta,
+ text_document_semantic_tokens_range
+ )
+
+ for (handler in handlers) {
+ before <- length(fixture$self$deliveries)
+ handler(fixture$self, before + 1L, params)
+ expect_length(fixture$self$deliveries, before + 1L)
+ expect_null(fixture$self$deliveries[[before + 1L]]$result)
+ }
+})
+
+test_that("latest queued replies supersede only the same document version", {
+ fixture <- langfeature_handler_fixture()
+ queue <- fixture$self$pending_replies$get(fixture$uri)[["textDocument/inlayHint"]]
+ queue$push(list(id = 1L, version = 3L))
+ queue$push(list(id = 2L, version = 4L))
+
+ enqueue_latest_reply(
+ fixture$self,
+ fixture$uri,
+ "textDocument/inlayHint",
+ list(id = 3L, version = 3L)
+ )
+
+ expect_length(fixture$self$deliveries, 1L)
+ expect_equal(fixture$self$deliveries[[1L]]$id, 1L)
+ expect_equal(queue$size(), 2L)
+ expect_equal(queue$pop()$id, 2L)
+ expect_equal(queue$pop()$id, 3L)
+})
+
+test_that("document link resolve reports provider errors to the user", {
+ fixture <- langfeature_handler_fixture()
+ handler <- document_link_resolve
+ stub(handler, "document_link_resolve_reply", function(id, ...) {
+ ResponseErrorMessage$new(id, "InternalError", "cannot resolve link")
+ })
+
+ handler(fixture$self, 1L, list(data = list(uri = fixture$uri)))
+
+ expect_length(fixture$self$deliveries, 2L)
+ expect_equal(fixture$self$deliveries[[1L]]$error$message, "cannot resolve link")
+ expect_equal(fixture$self$deliveries[[2L]]$method, "window/showMessage")
+ expect_equal(
+ fixture$self$deliveries[[2L]]$params$message,
+ "cannot resolve link"
+ )
+})
+
+test_that("initialization handles trace and multiple workspace folders", {
+ old_trace <- lsp_settings$get("trace")
+ old_log_file <- lsp_settings$get("log_file")
+ withr::defer({
+ lsp_settings$set("trace", old_trace)
+ lsp_settings$set("log_file", old_log_file)
+ })
+ lsp_settings$set("log_file", withr::local_tempfile())
+ self <- new.env(parent = baseenv())
+ self$workspaces <- collections::dict()
+ self$added <- character()
+ self$deliveries <- list()
+ self$add_workspace <- function(uri) {
+ self$added <- c(self$added, uri)
+ self$workspaces$set(uri, uri)
+ }
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ }
+ root <- path_to_uri(tempdir())
+ second <- path_to_uri(withr::local_tempdir())
+
+ on_initialize(self, 7L, list(
+ trace = "messages",
+ processId = 42L,
+ rootUri = root,
+ workspaceFolders = list(
+ list(uri = root, name = "root"),
+ list(uri = second, name = "second")
+ ),
+ initializationOptions = list(test = TRUE),
+ capabilities = list()
+ ))
+
+ expect_true(lsp_settings$get("trace"))
+ expect_equal(self$processId, 42L)
+ expect_equal(self$added, c(root, second))
+ expect_length(self$deliveries, 1L)
+ expect_false(is.null(self$deliveries[[1L]]$result$capabilities))
+})
+
+test_that("exit, cancellation, and trace notifications update server state", {
+ old_trace <- lsp_settings$get("trace")
+ withr::defer(lsp_settings$set("trace", old_trace))
+ self <- new.env(parent = baseenv())
+ self$exit_flag <- FALSE
+ self$deliveries <- list()
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ }
+ self$pending_replies <- collections::dict()
+ first <- collections::queue()
+ second <- collections::queue()
+ first$push(list(id = 11L))
+ first$push(list(id = 12L))
+ second$push(list(id = "11"))
+ self$pending_replies$set("file:///one.R", list(first, second))
+
+ cancel_request(self, list(id = 11L))
+ expect_equal(
+ vapply(self$deliveries, function(x) as.character(x$id), character(1L)),
+ c("11", "11")
+ )
+ expect_equal(first$size(), 1L)
+ expect_equal(first$peek()$id, 12L)
+ expect_equal(second$size(), 0L)
+
+ on_exit(self, NULL)
+ expect_true(self$exit_flag)
+ protocol_set_trace(self, list(value = "off"))
+ expect_false(lsp_settings$get("trace"))
+ protocol_set_trace(self, list(value = "verbose"))
+ expect_true(lsp_settings$get("trace"))
+})
diff --git a/tests/testthat/test-handlers-textsync.R b/tests/testthat/test-handlers-textsync.R
new file mode 100644
index 00000000..a67d7a3e
--- /dev/null
+++ b/tests/testthat/test-handlers-textsync.R
@@ -0,0 +1,199 @@
+textsync_fixture <- function(root = tempdir()) {
+ workspace <- new.env(parent = baseenv())
+ workspace$root <- root
+ workspace$documents <- collections::dict()
+ workspace$diagnostics_globals_cache <- "cached"
+ workspace$type_hierarchy_cache <- collections::dict()
+ workspace$type_hierarchy_cache$set("cached", TRUE)
+ workspace$update_count <- 0L
+ workspace$update_loaded_packages <- function() {
+ workspace$update_count <- workspace$update_count + 1L
+ }
+
+ self <- new.env(parent = baseenv())
+ self$pending_replies <- collections::dict()
+ self$deliveries <- list()
+ self$syncs <- list()
+ self$get_workspace <- function(...) workspace
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ }
+ self$text_sync <- function(...) {
+ self$syncs[[length(self$syncs) + 1L]] <- list(...)
+ }
+
+ list(self = self, workspace = workspace)
+}
+
+test_that("didOpen replaces stale documents and schedules immediate parsing", {
+ fixture <- textsync_fixture()
+ path <- file.path(fixture$workspace$root, "open.R")
+ uri <- path_to_uri(path)
+ stale <- Document$new(uri, version = 0L, content = "stale")
+ fixture$workspace$documents$set(uri, stale)
+
+ text_document_did_open(fixture$self, list(textDocument = list(
+ uri = uri,
+ languageId = "r",
+ version = 1L,
+ text = "first\nsecond"
+ )))
+
+ document <- fixture$workspace$documents$get(uri)
+ expect_equal(document$content, c("first", "second"))
+ expect_equal(document$version, 1L)
+ expect_true(document$is_open)
+ expect_length(fixture$self$syncs, 1L)
+ expect_equal(fixture$self$syncs[[1L]]$delay, 0)
+ expect_true(fixture$self$syncs[[1L]]$parse)
+})
+
+test_that("didOpen and didSave can read content from disk", {
+ fixture <- textsync_fixture()
+ path <- file.path(fixture$workspace$root, "saved.R")
+ writeLines(c("before", "save"), path)
+ uri <- path_to_uri(path)
+
+ text_document_did_open(fixture$self, list(textDocument = list(
+ uri = uri, languageId = "r", version = 1L, text = NULL
+ )))
+ expect_equal(
+ fixture$workspace$documents$get(uri)$content,
+ c("before", "save")
+ )
+
+ writeLines(c("after", "save"), path)
+ text_document_did_save(fixture$self, list(
+ textDocument = list(uri = uri), text = NULL
+ ))
+ expect_equal(
+ fixture$workspace$documents$get(uri)$content,
+ c("after", "save")
+ )
+
+ text_document_did_save(fixture$self, list(
+ textDocument = list(uri = uri), text = "client\ncontent"
+ ))
+ expect_equal(
+ fixture$workspace$documents$get(uri)$content,
+ c("client", "content")
+ )
+
+ missing_uri <- path_to_uri(file.path(fixture$workspace$root, "missing.R"))
+ expect_null(text_document_did_save(fixture$self, list(
+ textDocument = list(uri = missing_uri), text = "ignored"
+ )))
+})
+
+test_that("didChange cancels stale replies and applies incremental content", {
+ fixture <- textsync_fixture()
+ uri <- path_to_uri(file.path(fixture$workspace$root, "change.R"))
+ document <- Document$new(uri, version = 1L, content = "abc")
+ fixture$workspace$documents$set(uri, document)
+
+ queue <- collections::queue()
+ queue$push(list(id = 1L, version = 1L))
+ queue$push(list(id = 3L, version = 3L))
+ fixture$self$pending_replies$set(uri, list(completion = queue))
+
+ text_document_did_change(fixture$self, list(
+ textDocument = list(uri = uri, version = 2L),
+ contentChanges = list(list(
+ range = list(
+ start = list(line = 0L, character = 1L),
+ end = list(line = 0L, character = 2L)
+ ),
+ text = "X"
+ ))
+ ))
+
+ expect_equal(document$content, "aXc")
+ expect_equal(document$version, 2L)
+ expect_length(fixture$self$deliveries, 1L)
+ expect_false(is.null(fixture$self$deliveries[[1L]]$error))
+ expect_equal(fixture$self$deliveries[[1L]]$id, 1L)
+ expect_equal(queue$size(), 1L)
+ expect_equal(queue$peek()$id, 3L)
+ expect_equal(
+ fixture$self$syncs[[1L]]$parse_delay,
+ lsp_settings$get("parse_delay")
+ )
+})
+
+test_that("didChange tolerates a full replacement before didOpen", {
+ fixture <- textsync_fixture()
+ uri <- path_to_uri(file.path(fixture$workspace$root, "late-open.R"))
+
+ text_document_did_change(fixture$self, list(
+ textDocument = list(uri = uri, version = 4L),
+ contentChanges = list(
+ list(range = list(
+ start = list(line = 0L, character = 0L),
+ end = list(line = 0L, character = 0L)
+ ), text = "ignored"),
+ list(text = "full\nreplacement")
+ )
+ ))
+
+ document <- fixture$workspace$documents$get(uri)
+ expect_equal(document$content, c("full", "replacement"))
+ expect_equal(document$version, 4L)
+
+ other <- textsync_fixture()
+ other_uri <- path_to_uri(file.path(other$workspace$root, "incremental.R"))
+ text_document_did_change(other$self, list(
+ textDocument = list(uri = other_uri, version = 1L),
+ contentChanges = list(list(
+ range = list(
+ start = list(line = 0L, character = 0L),
+ end = list(line = 0L, character = 0L)
+ ),
+ text = "ignored"
+ ))
+ ))
+ expect_equal(other$workspace$documents$get(other_uri)$content, "")
+})
+
+test_that("didClose removes non-package documents and clears caches", {
+ fixture <- textsync_fixture()
+ path <- file.path(fixture$workspace$root, "closed.R")
+ uri <- path_to_uri(path)
+ document <- Document$new(uri, version = 1L, content = "value <- 1")
+ document$did_open()
+ fixture$workspace$documents$set(uri, document)
+ fixture$self$pending_replies$set(uri, list())
+
+ text_document_did_close(fixture$self, list(
+ textDocument = list(uri = uri)
+ ))
+
+ expect_false(fixture$workspace$documents$has(uri))
+ expect_null(fixture$workspace$diagnostics_globals_cache)
+ expect_equal(fixture$workspace$type_hierarchy_cache$size(), 0L)
+ expect_equal(fixture$workspace$update_count, 1L)
+ expect_false(fixture$self$pending_replies$has(uri))
+ expect_true(length(fixture$self$deliveries) >= 1L)
+})
+
+test_that("didClose retains documents belonging to an open package", {
+ package_root <- normalizePath(withr::local_tempdir())
+ writeLines(
+ c("Package: textsyncfixture", "Version: 0.0.1"),
+ file.path(package_root, "DESCRIPTION")
+ )
+ dir.create(file.path(package_root, "R"))
+ fixture <- textsync_fixture(package_root)
+ uri <- path_to_uri(file.path(package_root, "R", "retained.R"))
+ document <- Document$new(uri, version = 1L, content = "value <- 1")
+ document$did_open()
+ fixture$workspace$documents$set(uri, document)
+ fixture$self$pending_replies$set(uri, list())
+
+ text_document_did_close(fixture$self, list(
+ textDocument = list(uri = uri)
+ ))
+
+ expect_true(fixture$workspace$documents$has(uri))
+ expect_false(document$is_open)
+ expect_equal(fixture$workspace$update_count, 0L)
+})
diff --git a/tests/testthat/test-hover.R b/tests/testthat/test-hover.R
index 039d5709..889c5a9b 100644
--- a/tests/testthat/test-hover.R
+++ b/tests/testthat/test-hover.R
@@ -24,6 +24,115 @@ test_that("Simple hover works", {
expect_equal(result$range$end$character, 13)
})
+test_that("function argument hover falls back through sparse documentation", {
+ workspace <- new.env(parent = baseenv())
+ workspace$get_documentation <- function(...) "plain text"
+ workspace$get_signature <- function(...) NULL
+ expect_null(function_argument_hover_contents(
+ workspace, "target", NULL, "argument"
+ ))
+
+ workspace$get_documentation <- function(...) {
+ list(arguments = list("..." = "additional arguments"))
+ }
+ expect_equal(
+ function_argument_hover_contents(workspace, "target", NULL, "missing"),
+ "additional arguments"
+ )
+
+ workspace$get_documentation <- function(...) list(arguments = list())
+ expect_null(function_argument_hover_contents(
+ workspace, "target", NULL, "missing"
+ ))
+})
+
+test_that("hover handles package and literal token classes", {
+ fixture <- provider_fixture(c(
+ "base::mean",
+ "missingHoverPackage::fun",
+ "object@slot",
+ "'text'",
+ "# comment",
+ "1 + 2"
+ ))
+ fixture$workspace$get_help <- function(...) NULL
+ fixture$workspace$get_documentation <- function(...) NULL
+ fixture$workspace$get_signature <- function(...) NULL
+ fixture$workspace$get_definition <- function(...) NULL
+ fixture$workspace$guess_namespace <- function(...) NULL
+
+ outside <- hover_reply(
+ 1L,
+ fixture$uri,
+ fixture$workspace,
+ fixture$document,
+ list(row = 99L, col = 0L)
+ )
+ expect_null(outside$result)
+
+ installed <- hover_reply(
+ 2L, fixture$uri, fixture$workspace, fixture$document,
+ list(row = 0L, col = 1L)
+ )
+ expect_match(
+ paste(installed$result$contents, collapse = " "),
+ "base",
+ ignore.case = TRUE
+ )
+
+ missing <- hover_reply(
+ 3L, fixture$uri, fixture$workspace, fixture$document,
+ list(row = 1L, col = 2L)
+ )
+ expect_match(
+ paste(missing$result$contents, collapse = " "),
+ "not installed"
+ )
+
+ for (point in list(
+ list(row = 2L, col = 8L),
+ list(row = 3L, col = 2L),
+ list(row = 4L, col = 2L),
+ list(row = 5L, col = 2L)
+ )) {
+ expect_null(hover_reply(
+ 4L, fixture$uri, fixture$workspace, fixture$document, point
+ )$result)
+ }
+})
+
+test_that("hover combines fallback signatures with character and list docs", {
+ fixture <- provider_fixture("mystery")
+ fixture$workspace$get_help <- function(...) NULL
+ fixture$workspace$guess_namespace <- function(...) "workspace"
+ fixture$workspace$get_signature <- function(...) "mystery(value)"
+ fixture$workspace$get_definition <- function(...) NULL
+ point <- list(row = 0L, col = 2L)
+
+ fixture$workspace$get_documentation <- function(...) "character docs"
+ character_reply <- hover_reply(
+ 1L, fixture$uri, fixture$workspace, fixture$document, point
+ )
+ expect_match(character_reply$result$contents[[1L]], "mystery\\(value\\)")
+ expect_equal(character_reply$result$contents[[2L]], "character docs")
+
+ fixture$workspace$get_documentation <- function(...) {
+ list(description = "description docs")
+ }
+ description_reply <- hover_reply(
+ 2L, fixture$uri, fixture$workspace, fixture$document, point
+ )
+ expect_equal(description_reply$result$contents[[2L]], "description docs")
+
+ fixture$workspace$get_documentation <- function(...) {
+ list(description = "ignored", markdown = "markdown docs")
+ }
+ markdown_reply <- hover_reply(
+ 3L, fixture$uri, fixture$workspace, fixture$document, point
+ )
+ expect_equal(markdown_reply$result$contents[[2L]], "markdown docs")
+})
+
test_that("Hover on user function works", {
skip_on_cran()
client <- language_client()
diff --git a/tests/testthat/test-inlay-hint.R b/tests/testthat/test-inlay-hint.R
index 7c618be7..90672d3a 100644
--- a/tests/testthat/test-inlay-hint.R
+++ b/tests/testthat/test-inlay-hint.R
@@ -169,3 +169,121 @@ test_that("inlay hints work through the language server", {
expect_match(resolved$tooltip$value, "```r\\nrnorm\\(")
expect_match(resolved$tooltip$value, "`mean` - vector of means")
})
+
+test_that("inlay hint helpers handle malformed and empty calls", {
+ no_parentheses <- xml2::read_xml("x")
+ reversed <- xml2::read_xml(paste0(
+ ")",
+ "("
+ ))
+ empty <- provider_fixture("target()")$document$parse_data$xml_doc
+ empty_call <- xml_find_first(empty, "//expr[expr/SYMBOL_FUNCTION_CALL]")
+
+ expect_length(call_argument_groups(no_parentheses), 0L)
+ expect_length(call_argument_groups(reversed), 0L)
+ groups <- call_argument_groups(empty_call)
+ expect_length(groups, 1L)
+ expect_length(groups[[1L]]$nodes, 0L)
+
+ expect_equal(match_named_formal("alpha", c("alpha", "beta")), 1L)
+ expect_equal(match_named_formal("al", c("alpha", "beta")), 1L)
+ expect_true(is.na(match_named_formal("a", c("alpha", "alpine"))))
+})
+
+test_that("inlay hints handle empty parse data and boundary ranges", {
+ fixture <- provider_fixture("target(one, two)")
+ fixture$document$parse_data$xml_doc <- NULL
+ request <- list(
+ start = list(line = 0L, character = 0L),
+ end = list(line = 1L, character = 0L)
+ )
+ expect_length(inlay_hint_reply(
+ 1L, fixture$uri, fixture$workspace, fixture$document, request
+ )$result, 0L)
+
+ fixture <- provider_fixture("value <- 1")
+ expect_length(inlay_hint_reply(
+ 2L, fixture$uri, fixture$workspace, fixture$document, request
+ )$result, 0L)
+})
+
+test_that("inlay hints validate settings and stop at formal boundaries", {
+ old_minimum <- lsp_settings$get("inlay_hints_minimum_arguments")
+ old_length <- lsp_settings$get("inlay_hints_minimum_argument_length")
+ withr::defer({
+ lsp_settings$set("inlay_hints_minimum_arguments", old_minimum)
+ lsp_settings$set("inlay_hints_minimum_argument_length", old_length)
+ })
+ lsp_settings$set("inlay_hints_minimum_arguments", NA_real_)
+ lsp_settings$set("inlay_hints_minimum_argument_length", -1L)
+ request <- list(
+ start = list(line = 0L, character = 0L),
+ end = list(line = 0L, character = 100L)
+ )
+
+ missing_formals <- provider_fixture("target(one, two)")
+ expect_length(inlay_hint_reply(
+ 1L,
+ missing_formals$uri,
+ missing_formals$workspace,
+ missing_formals$document,
+ request
+ )$result, 0L)
+
+ too_many <- provider_fixture(
+ "target(one, two)",
+ formals_resolver = function(...) alist(first =)
+ )
+ expect_equal(
+ vapply(inlay_hint_reply(
+ 2L, too_many$uri, too_many$workspace, too_many$document, request
+ )$result, `[[`, character(1L), "label"),
+ "first ="
+ )
+
+ dots <- provider_fixture(
+ "target(one, two)",
+ formals_resolver = function(...) alist(... =)
+ )
+ expect_length(inlay_hint_reply(
+ 3L, dots$uri, dots$workspace, dots$document, request
+ )$result, 0L)
+
+ outside <- provider_fixture(
+ "target(one, two)",
+ formals_resolver = function(...) alist(first =, second =)
+ )
+ outside_request <- request
+ outside_request$start$character <- 12L
+ expect_equal(
+ vapply(inlay_hint_reply(
+ 4L, outside$uri, outside$workspace, outside$document, outside_request
+ )$result, `[[`, character(1L), "label"),
+ "second ="
+ )
+})
+
+test_that("inlay hint resolution tolerates missing metadata and documentation", {
+ fixture <- provider_fixture("value <- 1")
+ fixture$workspace$get_documentation <- function(...) NULL
+ fixture$workspace$get_signature <- function(...) NULL
+ unresolved <- list(label = "value =", data = list())
+ expect_identical(
+ inlay_hint_resolve_reply(1L, fixture$workspace, unresolved)$result,
+ unresolved
+ )
+
+ hint <- list(
+ label = "parameter =",
+ data = list(
+ functionName = "target",
+ parameter = "parameter",
+ package = "pkg"
+ )
+ )
+ resolved <- inlay_hint_resolve_reply(2L, fixture$workspace, hint)$result
+ expect_equal(
+ resolved$tooltip$value,
+ "Parameter `parameter` of `pkg::target()`."
+ )
+})
diff --git a/tests/testthat/test-inline-value.R b/tests/testthat/test-inline-value.R
index 377706d8..6b9a3849 100644
--- a/tests/testthat/test-inline-value.R
+++ b/tests/testthat/test-inline-value.R
@@ -56,3 +56,51 @@ test_that("inline values work through the language server", {
expect_true("x" %in% vapply(
result, `[[`, character(1L), "variableName"))
})
+
+test_that("inline values handle empty XML, ranges, and duplicate variables", {
+ request <- list(
+ start = list(line = 0L, character = 0L),
+ end = list(line = 1L, character = 0L)
+ )
+ fixture <- provider_fixture("value <- 1")
+ fixture$document$parse_data$xml_doc <- NULL
+ expect_length(inline_value_reply(
+ 1L, fixture$uri, fixture$workspace, fixture$document, request
+ )$result, 0L)
+
+ no_symbols <- provider_fixture(c("# comment", "value <- 1"))
+ expect_length(inline_value_reply(
+ 2L,
+ no_symbols$uri,
+ no_symbols$workspace,
+ no_symbols$document,
+ request
+ )$result, 0L)
+
+ repeated <- provider_fixture("function(...) value + value")
+ full_range <- list(
+ start = list(line = 0L, character = 0L),
+ end = list(line = 0L, character = 30L)
+ )
+ values <- inline_value_reply(
+ 3L,
+ repeated$uri,
+ repeated$workspace,
+ repeated$document,
+ full_range
+ )$result
+ expect_equal(
+ sum(vapply(values, `[[`, character(1L), "variableName") == "value"),
+ 1L
+ )
+
+ after_first <- full_range
+ after_first$start$character <- 20L
+ expect_length(inline_value_reply(
+ 4L,
+ repeated$uri,
+ repeated$workspace,
+ repeated$document,
+ after_first
+ )$result, 1L)
+})
diff --git a/tests/testthat/test-interfaces.R b/tests/testthat/test-interfaces.R
new file mode 100644
index 00000000..de9ff50d
--- /dev/null
+++ b/tests/testthat/test-interfaces.R
@@ -0,0 +1,87 @@
+test_that("LSP positions, ranges, and locations validate and print", {
+ start <- position(1L, 2L)
+ end <- position(3L, 4L)
+ selection <- range(start, end)
+ uri <- document_uri("file:///interfaces.R")
+ where <- location(uri, selection)
+
+ expect_error(position("1", 2L), "numeric arguments")
+ expect_error(range(start, list()), "position")
+ expect_error(location(uri, list()), "range")
+ expect_error(document_uri(1L), "character parameter")
+
+ expect_output(print.position(start), " Line: 1")
+ expect_output(print.range(selection), "")
+ expect_output(
+ print.document_uri(uri),
+ " file:///interfaces.R",
+ fixed = TRUE
+ )
+ expect_output(print.location(where), "")
+})
+
+test_that("LSP value constructors preserve optional fields", {
+ uri <- document_uri("file:///interfaces.R")
+ selection <- range(position(0L, 0L), position(0L, 4L))
+ child <- document_symbol(
+ "child", SymbolKind$Variable, selection, selection
+ )
+ parent <- document_symbol(
+ "parent", SymbolKind$Function, selection, selection,
+ detail = "function", children = list(child)
+ )
+
+ expect_s3_class(symbol_information(
+ "symbol", SymbolKind$Variable, location(uri, selection)
+ ), "symbol_information")
+ expect_equal(parent$detail, "function")
+ expect_identical(parent$children, list(child))
+ expect_null(child$detail)
+ expect_null(child$children)
+
+ edit <- text_edit(selection, "replacement")
+ expect_s3_class(edit, "text_edit")
+ expect_equal(edit$newText, "replacement")
+ expect_s3_class(
+ text_document_position_params(uri, position(0L, 1L)),
+ "text_document_position_params"
+ )
+})
+
+test_that("Request parameter constructors use the protocol field names", {
+ uri <- document_uri("file:///params.R")
+ point <- position(1L, 2L)
+ selection <- range(point, position(1L, 3L))
+ options <- list(tabSize = 2L, insertSpaces = TRUE)
+ context <- list(triggerKind = 1L)
+
+ cases <- list(
+ completion_params(uri, point, context),
+ reference_params(uri, point, context),
+ document_symbol_params(uri),
+ code_action_params(uri, selection, context),
+ code_lens_params(uri),
+ document_link_params(uri),
+ document_formatting_params(uri, options),
+ document_range_formatting_params(uri, selection, options),
+ document_on_type_formatting_params(uri, point, "\n", options),
+ rename_params(uri, point, "renamed"),
+ did_open_text_document_params(uri),
+ did_change_text_document_params(uri, list(list(text = "changed"))),
+ will_save_text_document_params(uri, 1L),
+ did_save_text_document_params(uri, "saved"),
+ did_close_text_document_params(uri),
+ did_change_configuration_params(list(languageserver = list(debug = TRUE)))
+ )
+
+ expect_true(all(vapply(cases, function(params) {
+ is.list(params) && length(class(params)) == 1L
+ }, logical(1L))))
+ expect_identical(cases[[1L]]$context, context)
+ expect_identical(cases[[4L]]$range, selection)
+ expect_identical(cases[[8L]]$options, options)
+ expect_equal(cases[[9L]]$character, "\n")
+ expect_equal(cases[[10L]]$newName, "renamed")
+ expect_equal(cases[[14L]]$text, "saved")
+ expect_true(cases[[16L]]$languageserver$debug)
+})
diff --git a/tests/testthat/test-langauagecilent.R b/tests/testthat/test-langauagecilent.R
index eaaca868..94a4c43a 100644
--- a/tests/testthat/test-langauagecilent.R
+++ b/tests/testthat/test-langauagecilent.R
@@ -13,3 +13,18 @@ test_that("read_line and read_char works", {
expect_equal(cilent$read_line(), "xyz")
expect_equal(cilent$read_line(), "third line")
})
+
+test_that("LanguageClient reports dead servers and reads stderr", {
+ client <- LanguageClient$new()
+ dead_process <- new.env(parent = baseenv())
+ dead_process$is_alive <- function() FALSE
+ client$process <- dead_process
+ expect_error(client$check_connection(), "Server is dead")
+
+ live_process <- new.env(parent = baseenv())
+ live_process$is_alive <- function() TRUE
+ live_process$read_error_lines <- function() c("first", "second")
+ client$process <- live_process
+ expect_equal(client$read_error(), "first\nsecond")
+ client$process <- NULL
+})
diff --git a/tests/testthat/test-languagebase.R b/tests/testthat/test-languagebase.R
new file mode 100644
index 00000000..84887333
--- /dev/null
+++ b/tests/testthat/test-languagebase.R
@@ -0,0 +1,116 @@
+TestLanguageBase <- R6::R6Class(
+ "TestLanguageBase",
+ inherit = LanguageBase,
+ public = list(
+ lines = NULL,
+ chars = NULL,
+ writes = NULL,
+ notifications = NULL,
+ initialize = function(lines = list(), chars = list()) {
+ self$lines <- lines
+ self$chars <- chars
+ self$writes <- character()
+ self$notifications <- list()
+ super$initialize()
+ },
+ register_handlers = function() {
+ self$request_handlers <- list(
+ echo = function(self, id, params) {
+ self$deliver(Response$new(id, result = params))
+ },
+ fail = function(...) stop("request failed")
+ )
+ self$notification_handlers <- list(
+ record = function(self, params) {
+ self$notifications[[length(self$notifications) + 1L]] <- params
+ },
+ fail = function(...) stop("notification failed")
+ )
+ },
+ read_line = function() {
+ if (!length(self$lines)) return(character())
+ value <- self$lines[[1L]]
+ self$lines <- self$lines[-1L]
+ value
+ },
+ read_char = function(...) {
+ if (!length(self$chars)) return(character())
+ value <- self$chars[[1L]]
+ self$chars <- self$chars[-1L]
+ value
+ },
+ write_text = function(text) {
+ self$writes <- c(self$writes, text)
+ },
+ check_connection = function() invisible(NULL)
+ )
+)
+
+test_that("LanguageBase reads fragmented headers and content", {
+ base <- TestLanguageBase$new(
+ lines = list("Content-Length: 2", character(), ""),
+ chars = list(character(), "a", "b")
+ )
+ expect_equal(base$read_header(), 2L)
+ expect_equal(base$read_content(2L), "ab")
+
+ malformed <- TestLanguageBase$new(lines = list("Wrong: header", ""))
+ expect_error(malformed$read_header(), "Unexpected non-empty line")
+})
+
+test_that("LanguageBase delivery stores callbacks and ignores NULL", {
+ base <- TestLanguageBase$new()
+ expect_null(base$deliver(NULL))
+ request <- base$request("echo", list(value = 1L))
+ callback <- function(...) NULL
+ base$deliver(request, callback)
+
+ expect_length(base$writes, 1L)
+ expect_true(base$request_callbacks$has(as.character(request$id)))
+})
+
+test_that("LanguageBase handles malformed and unknown payloads", {
+ old_log_file <- lsp_settings$get("log_file")
+ withr::defer(lsp_settings$set("log_file", old_log_file))
+ lsp_settings$set("log_file", withr::local_tempfile())
+
+ base <- TestLanguageBase$new()
+ expect_null(base$handle_raw("{"))
+ expect_null(base$handle_raw("{}"))
+
+ base$handle_request(list(id = 1L, method = "fail", params = list()))
+ base$handle_request(list(id = 2L, method = "unknown", params = list()))
+ expect_length(base$writes, 2L)
+ expect_match(base$writes[[1L]], '"code":-32603', fixed = TRUE)
+ expect_match(base$writes[[2L]], '"code":-32601', fixed = TRUE)
+
+ expect_null(base$handle_notification(list(
+ method = "fail", params = list()
+ )))
+ expect_null(base$handle_notification(list(
+ method = "unknown", params = list()
+ )))
+})
+
+test_that("LanguageBase isolates callback failures for results and errors", {
+ base <- TestLanguageBase$new()
+ result_request <- base$request("result", list())
+ error_request <- base$request("error", list())
+ base$request_callbacks$set(
+ as.character(result_request$id),
+ function(self, result) stop("result callback failed")
+ )
+ base$request_callbacks$set(
+ as.character(error_request$id),
+ function(self, result, error) stop("error callback failed")
+ )
+
+ expect_null(base$handle_response(list(
+ id = result_request$id, result = "ok", error = NULL
+ )))
+ expect_null(base$handle_response(list(
+ id = error_request$id,
+ result = NULL,
+ error = list(message = "broken")
+ )))
+})
diff --git a/tests/testthat/test-languageserver-core.R b/tests/testthat/test-languageserver-core.R
new file mode 100644
index 00000000..42c5a48f
--- /dev/null
+++ b/tests/testthat/test-languageserver-core.R
@@ -0,0 +1,147 @@
+BareLanguageServer <- R6::R6Class(
+ "BareLanguageServer",
+ inherit = LanguageServer,
+ private = list(
+ close_connection = function(connection) {
+ tryCatch({
+ if (isOpen(connection)) {
+ close(connection)
+ }
+ }, error = function(e) NULL)
+ },
+ finalize = function() {
+ private$close_connection(self$inputcon)
+ if (!identical(self$outputcon, self$inputcon)) {
+ private$close_connection(self$outputcon)
+ }
+ self$request_callbacks$clear()
+ }
+ ),
+ public = list(
+ initialize = function() {
+ self$inputcon <- rawConnection(raw(), open = "r+")
+ self$outputcon <- textConnection(NULL, open = "w")
+ self$exit_flag <- FALSE
+ self$pending_replies <- collections::dict()
+ self$workspaces <- collections::dict()
+ self$workspace_cache <- collections::dict()
+ self$workspaces$set(DEFAULT_WORKSPACE, Workspace$new(NULL))
+ self$rootUri <- character()
+ self$request_callbacks <- collections::dict()
+ self$register_handlers()
+ },
+ close_connections = function() {
+ private$finalize()
+ }
+ )
+)
+
+ErrorLanguageServer <- R6::R6Class(
+ "ErrorLanguageServer",
+ inherit = BareLanguageServer,
+ public = list(
+ stops = NULL,
+ initialize = function() {
+ super$initialize()
+ self$stops <- new.env(parent = emptyenv())
+ self$stops$count <- 0L
+ manager <- new.env(parent = baseenv())
+ manager$stop <- function() {
+ self$stops$count <- self$stops$count + 1L
+ }
+ self$parse_task_manager <- manager
+ self$diagnostics_task_manager <- manager
+ self$resolve_task_manager <- manager
+ },
+ process_events = function() stop("event loop failed")
+ )
+)
+
+test_that("LanguageServer removes workspaces and preserves open documents", {
+ old_diagnostics <- lsp_settings$get("diagnostics")
+ withr::defer(lsp_settings$set("diagnostics", old_diagnostics))
+ lsp_settings$set("diagnostics", FALSE)
+ server <- BareLanguageServer$new()
+ withr::defer(server$close_connections())
+ root <- withr::local_tempdir()
+ uri <- path_to_uri(root)
+ workspace <- Workspace$new(root)
+ open_uri <- path_to_uri(file.path(root, "open.R"))
+ closed_uri <- path_to_uri(file.path(root, "closed.R"))
+ open_document <- Document$new(open_uri, content = "open <- TRUE")
+ open_document$did_open()
+ workspace$documents$set(open_uri, open_document)
+ workspace$documents$set(
+ closed_uri,
+ Document$new(closed_uri, content = "closed <- TRUE")
+ )
+ server$workspaces$set(uri, workspace)
+ server$workspace_cache$set(open_uri, workspace)
+
+ expect_null(server$remove_workspace(character()))
+ server$remove_workspace(uri)
+
+ expect_false(server$workspaces$has(uri))
+ expect_true(
+ server$workspaces$get(DEFAULT_WORKSPACE)$documents$has(open_uri)
+ )
+ expect_false(
+ server$workspaces$get(DEFAULT_WORKSPACE)$documents$has(closed_uri)
+ )
+ expect_equal(server$workspace_cache$size(), 0L)
+})
+
+test_that("LanguageServer detects closed input and reads UTF-8 TCP bytes", {
+ server <- BareLanguageServer$new()
+ withr::defer(server$close_connections())
+ close(server$inputcon)
+ server$inputcon <- file(tempfile())
+ server$check_connection()
+ expect_true(server$exit_flag)
+
+ closed_input <- server$inputcon
+ utf8_input <- rawConnection(charToRaw("\u00e9"), open = "rb")
+ server$inputcon <- utf8_input
+ server$tcp <- TRUE
+ expect_equal(server$read_char(2L), "\u00e9")
+
+ server$inputcon <- rawConnection(raw(), open = "r+")
+ close(utf8_input)
+ close(closed_input)
+})
+
+test_that("LanguageServer stops managers after an event loop error", {
+ old_log_file <- lsp_settings$get("log_file")
+ withr::defer(lsp_settings$set("log_file", old_log_file))
+ lsp_settings$set("log_file", withr::local_tempfile())
+
+ server <- ErrorLanguageServer$new()
+ withr::defer(server$close_connections())
+ expect_null(server$run())
+ expect_equal(server$stops$count, 3L)
+})
+
+test_that("run configures boolean and file debug modes", {
+ old_debug <- lsp_settings$get("debug")
+ old_log_file <- lsp_settings$get("log_file")
+ withr::defer({
+ lsp_settings$set("debug", old_debug)
+ lsp_settings$set("log_file", old_log_file)
+ })
+ fake_server <- new.env(parent = emptyenv())
+ fake_server$runs <- 0L
+ fake_server$run <- function() {
+ fake_server$runs <- fake_server$runs + 1L
+ }
+ runner <- run
+ stub(runner, "LanguageServer$new", function(...) fake_server)
+
+ runner(debug = TRUE)
+ expect_true(lsp_settings$get("debug"))
+ expect_null(lsp_settings$get("log_file"))
+
+ log_file <- withr::local_tempfile()
+ runner(debug = log_file)
+ expect_equal(lsp_settings$get("log_file"), log_file)
+ expect_equal(fake_server$runs, 2L)
+})
diff --git a/tests/testthat/test-link-core.R b/tests/testthat/test-link-core.R
new file mode 100644
index 00000000..d2973cb4
--- /dev/null
+++ b/tests/testthat/test-link-core.R
@@ -0,0 +1,19 @@
+test_that("Document link resolution reports missing and oversized files", {
+ missing_path <- file.path(withr::local_tempdir(), "missing.R")
+ missing <- document_link_resolve_reply(
+ 1L, NULL, list(data = list(path = missing_path))
+ )
+ expect_equal(missing$error$code, ErrorCodes$RequestCancelled)
+ expect_match(missing$error$message, "missing")
+
+ old_limit <- lsp_settings$get("link_file_size_limit")
+ withr::defer(lsp_settings$set("link_file_size_limit", old_limit))
+ lsp_settings$set("link_file_size_limit", 1L)
+ path <- withr::local_tempfile()
+ writeLines("larger than one byte", path)
+ oversized <- document_link_resolve_reply(
+ 2L, NULL, list(data = list(path = path))
+ )
+ expect_equal(oversized$error$code, ErrorCodes$RequestCancelled)
+ expect_match(oversized$error$message, "exceeds the limit")
+})
diff --git a/tests/testthat/test-linked-editing.R b/tests/testthat/test-linked-editing.R
index 3f488a5a..7a297d71 100644
--- a/tests/testthat/test-linked-editing.R
+++ b/tests/testthat/test-linked-editing.R
@@ -39,3 +39,39 @@ test_that("linked editing works through the language server", {
)
expect_length(result$ranges, 2L)
})
+
+test_that("linked editing rejects incomplete definitions and documentation", {
+ point <- list(line = 0L, character = 0L)
+ fixture <- provider_fixture("value <- 1")
+ fixture$document$parse_data$xml_doc <- NULL
+ expect_null(linked_editing_range_reply(
+ 1L, fixture$uri, fixture$workspace, fixture$document, point
+ )$result)
+
+ cases <- list(
+ list(content = "value <- 1", definitions = list(value = list(
+ type = "double", range = range(position(0L, 0L), position(0L, 5L))
+ ))),
+ list(content = "value <- 1", definitions = list(missing = list(
+ type = "function", range = range(position(0L, 0L), position(0L, 5L))
+ ))),
+ list(content = "foo <- function() 1", definitions = NULL),
+ list(content = c("#' @param other docs", "foo <- function(x) x"), definitions = NULL)
+ )
+ for (case in cases) {
+ item <- provider_fixture(case$content)
+ if (!is.null(case$definitions)) {
+ item$document$parse_data$definitions <- case$definitions
+ }
+ expect_null(linked_editing_range_reply(
+ 2L, item$uri, item$workspace, item$document, point
+ )$result)
+ }
+
+ documented <- Document$new(
+ "file:///empty-param.R",
+ content = c("#' @param x,,y docs", "foo <- function(x, y) NULL")
+ )
+ ranges <- roxygen_parameter_ranges(documented, 1L)
+ expect_setequal(names(ranges), c("x", "y"))
+})
diff --git a/tests/testthat/test-lintr.R b/tests/testthat/test-lintr.R
index 41f1c49b..f61bf0b1 100644
--- a/tests/testthat/test-lintr.R
+++ b/tests/testthat/test-lintr.R
@@ -87,3 +87,125 @@ test_that("lintr is disabled", {
data <- client %>% wait_for("textDocument/publishDiagnostics", timeout = runif(1, 1, 3))
expect_null(data)
})
+
+test_that("Diagnostic conversion handles ranges, Unicode, and severities", {
+ content <- paste0("x", intToUtf8(0x10400), "y")
+ point_lint <- list(
+ line_number = 1L,
+ column_number = NA_integer_,
+ ranges = NULL,
+ type = "error",
+ message = "problem",
+ linter = "example_linter"
+ )
+ ranged_lint <- within(point_lint, {
+ column_number <- 2L
+ ranges <- list(c(2L, 2L))
+ type <- "warning"
+ })
+
+ expect_equal(diagnostic_range(point_lint, content)$start$character, 0L)
+ expect_equal(diagnostic_range(ranged_lint, content)$end$character, 3L)
+ expect_equal(diagnostic_severity(point_lint), DiagnosticSeverity$Error)
+ expect_equal(diagnostic_severity(ranged_lint), DiagnosticSeverity$Warning)
+ expect_equal(
+ diagnostic_severity(within(point_lint, type <- "style")),
+ DiagnosticSeverity$Information
+ )
+ expect_equal(
+ diagnostic_severity(within(point_lint, type <- "other")),
+ DiagnosticSeverity$Information
+ )
+
+ converted <- diagnostic_from_lint(ranged_lint, content)
+ expect_equal(converted$source, "lintr")
+ expect_equal(converted$code, "example_linter")
+ expect_match(converted$codeDescription$href, "example_linter.html", fixed = TRUE)
+})
+
+test_that("diagnose_file handles empty, prose-only, and untitled content", {
+ expect_identical(diagnose_file("untitled:1", character()), list())
+ expect_identical(
+ diagnose_file(
+ "file:///prose.Rmd", c("# Title", "Plain prose"),
+ is_rmarkdown = TRUE
+ ),
+ list()
+ )
+
+ diagnostics <- suppressWarnings(diagnose_file(
+ "untitled:1", "value=1", cache = FALSE
+ ))
+ expect_true(length(diagnostics) >= 1L)
+ expect_true(all(vapply(diagnostics, function(item) {
+ identical(item$source, "lintr")
+ }, logical(1L))))
+
+ globals <- new.env(parent = emptyenv())
+ globals$known_global <- TRUE
+ expect_type(suppressWarnings(diagnose_file(
+ "untitled:1", "known_global", globals = globals, cache = FALSE
+ )), "list")
+ expect_false("languageserver:globals" %in% search())
+})
+
+test_that("diagnostic callbacks reject stale results and publish current ones", {
+ uri <- "file:///diagnostics-callback.R"
+ document <- Document$new(uri, version = 2L, content = "value <- 1")
+ documents <- collections::dict()
+ documents$set(uri, document)
+ workspace <- list(documents = documents)
+ self <- new.env(parent = baseenv())
+ self$get_workspace <- function(...) workspace
+ self$deliveries <- list()
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ }
+
+ expect_null(diagnostics_callback(self, uri, 1L, list()))
+ expect_length(self$deliveries, 0L)
+ expect_null(diagnostics_callback(self, uri, 2L, NULL))
+
+ diagnostics_callback(self, uri, 2L, list())
+ expect_length(self$deliveries, 1L)
+ expect_equal(
+ self$deliveries[[1L]]$method,
+ "textDocument/publishDiagnostics"
+ )
+ expect_equal(self$deliveries[[1L]]$params$version, 2L)
+})
+
+test_that("diagnostics_task reuses fresh cached results", {
+ uri <- "file:///cached-diagnostics.R"
+ document <- Document$new(uri, version = 3L, content = "value <- 1")
+ documents <- collections::dict()
+ documents$set(uri, document)
+ workspace <- new.env(parent = baseenv())
+ workspace$root <- tempdir()
+ workspace$documents <- documents
+ workspace$diagnostics_cache <- ByteLruCache$new(1024^2)
+ key <- paste(uri, get_content_hash(document$content), sep = "::")
+ cached <- list(list(message = "cached"))
+ workspace$diagnostics_cache$set(key, list(
+ time = Sys.time(), diagnostics = cached
+ ))
+
+ self <- new.env(parent = baseenv())
+ self$get_workspace <- function(...) workspace
+ self$deliveries <- list()
+ self$deliver <- function(message) {
+ self$deliveries[[length(self$deliveries) + 1L]] <- message
+ }
+ old_ttl <- lsp_settings$get("diagnostics_cache_ttl")
+ withr::defer(lsp_settings$set("diagnostics_cache_ttl", old_ttl))
+ lsp_settings$set("diagnostics_cache_ttl", 60)
+
+ expect_null(diagnostics_task(self, uri, document))
+ expect_length(self$deliveries, 1L)
+ expect_identical(self$deliveries[[1L]]$params$diagnostics, cached)
+
+ lsp_settings$set("diagnostics_cache_ttl", NULL)
+ task <- diagnostics_task(self, uri, document, delay = -1)
+ expect_s3_class(task, "Task")
+ expect_equal(task$delay, 0)
+})
diff --git a/tests/testthat/test-lsp-3-18.R b/tests/testthat/test-lsp-3-18.R
index b00968cb..a0112e08 100644
--- a/tests/testthat/test-lsp-3-18.R
+++ b/tests/testthat/test-lsp-3-18.R
@@ -9,6 +9,14 @@ test_that("general LSP 3.18 capabilities are advertised", {
expect_equal(tail(ServerCapabilities$semanticTokensProvider$legend$tokenTypes, 1), "label")
})
+test_that("rename prepare capability follows client support", {
+ capabilities <- update_server_capabilities(
+ ServerCapabilities,
+ list(textDocument = list(rename = list(prepareSupport = TRUE)))
+ )
+ expect_equal(capabilities$renameProvider, RenameOptions)
+})
+
test_that("incremental document changes are sequential and UTF-16 aware", {
document <- Document$new(
"file:///incremental.R",
diff --git a/tests/testthat/test-native-utilities.R b/tests/testthat/test-native-utilities.R
new file mode 100644
index 00000000..3f99e0b0
--- /dev/null
+++ b/tests/testthat/test-native-utilities.R
@@ -0,0 +1,138 @@
+test_that("native string matching is case-insensitive and NA-safe", {
+ values <- c("LanguageServer", "server", "client", NA_character_)
+
+ expect_identical(
+ match_with(values, "SERVER"),
+ c(TRUE, TRUE, FALSE, FALSE)
+ )
+ expect_identical(match_with(values, ""), c(TRUE, TRUE, TRUE, FALSE))
+ expect_identical(match_with("short", "a much longer pattern"), FALSE)
+ expect_identical(match_with(values, NA_character_), rep(NA, 4L))
+ expect_identical(
+ .Call("match_with_c", values, "server", PACKAGE = "languageserver"),
+ c(TRUE, TRUE, FALSE, NA)
+ )
+
+ expect_identical(
+ fuzzy_find(values, "LS"),
+ c(TRUE, FALSE, FALSE, FALSE)
+ )
+ expect_identical(fuzzy_find(values, ""), c(TRUE, TRUE, TRUE, FALSE))
+ expect_identical(fuzzy_find(values, NA_character_), rep(NA, 4L))
+ expect_identical(
+ .Call("fuzzy_find_c", values, "ls", PACKAGE = "languageserver"),
+ c(TRUE, FALSE, FALSE, NA)
+ )
+})
+
+test_that("native string matching validates its low-level inputs", {
+ expect_error(
+ .Call("match_with_c", 1:3, "x", PACKAGE = "languageserver"),
+ "x must be a character vector"
+ )
+ expect_error(
+ .Call("match_with_c", "x", c("x", "y"), PACKAGE = "languageserver"),
+ "token must be a single character string"
+ )
+ expect_error(
+ .Call("fuzzy_find_c", 1:3, "x", PACKAGE = "languageserver"),
+ "x must be a character vector"
+ )
+ expect_error(
+ .Call("fuzzy_find_c", "x", 1L, PACKAGE = "languageserver"),
+ "pattern must be a single character string"
+ )
+})
+
+test_that("token scanning recognizes namespace and identifier boundaries", {
+ expect_equal(
+ scan_token("pkg::", 5L),
+ list(
+ full_token = "pkg::", right_token = "", package = "pkg",
+ accessor = "::", token = ""
+ )
+ )
+ expect_equal(
+ scan_token("pkg:::hidden", 6L),
+ list(
+ full_token = "pkg:::hidden", right_token = "hidden",
+ package = "pkg", accessor = ":::", token = "hidden"
+ )
+ )
+ expect_equal(scan_token("pkg::fun", 8L, forward = FALSE)$token, "fun")
+ expect_equal(scan_token("pkg::fun", 5L)$right_token, "fun")
+ unicode_name <- paste0(intToUtf8(0xe9), "clair")
+ expect_equal(
+ scan_token(unicode_name, 6L, forward = FALSE)$token,
+ unicode_name
+ )
+
+ expect_equal(scan_token("x$member", 8L, forward = FALSE)$token, "")
+ expect_equal(scan_token("1abc", 4L, forward = FALSE)$token, "")
+ expect_equal(scan_token("a::", 3L)$package, "")
+ expect_equal(scan_token("abc", -2L)$right_token, "abc")
+ expect_equal(scan_token("pkg::", 99L)$accessor, "::")
+})
+
+test_that("native token scanning validates scalar input types", {
+ expect_error(
+ .Call("scan_token_c", c("x", "y"), 0L, TRUE,
+ PACKAGE = "languageserver"),
+ "line must be a single character string"
+ )
+ expect_error(
+ .Call("scan_token_c", "x", 0, TRUE, PACKAGE = "languageserver"),
+ "col must be a single integer"
+ )
+})
+
+test_that("UTF-16 conversion handles every UTF-8 width and boundary", {
+ text <- intToUtf8(c(0x61, 0xe9, 0x4f62, 0x10400, 0x7a))
+
+ expect_equal(
+ code_point_to_unit(text, c(-1, 0:6, Inf)),
+ c(0, 0, 1, 2, 3, 5, 6, 6, 6)
+ )
+ expect_equal(
+ code_point_from_unit(text, c(-1, 0:7, Inf)),
+ c(0, 0, 1, 2, 3, NA, 4, 5, 5, 5)
+ )
+ expect_identical(code_point_to_unit("", integer()), integer())
+ expect_identical(code_point_from_unit("", integer()), integer())
+})
+
+test_that("native UTF-16 conversion rejects malformed argument types", {
+ expect_error(
+ .Call("code_point_to_unit_c", c("x", "y"), 0L,
+ PACKAGE = "languageserver"),
+ "line must be a single character string"
+ )
+ expect_error(
+ .Call("code_point_to_unit_c", "x", 0,
+ PACKAGE = "languageserver"),
+ "points must be an integer vector"
+ )
+ expect_error(
+ .Call("code_point_from_unit_c", 1L, 0L,
+ PACKAGE = "languageserver"),
+ "line must be a single character string"
+ )
+ expect_error(
+ .Call("code_point_from_unit_c", "x", 0,
+ PACKAGE = "languageserver"),
+ "units must be an integer vector"
+ )
+})
+
+test_that("quote detection handles backticks and raw-string delimiters", {
+ enclosed <- function(text, col) {
+ .Call("enclosed_by_quotes", text, col, PACKAGE = "languageserver")
+ }
+
+ expect_true(enclosed("R'[raw text", 5L))
+ expect_true(enclosed("R\"[raw text", 5L))
+ expect_true(enclosed("R'{raw text", 5L))
+ expect_false(enclosed("R'[raw]' + value", 12L))
+ expect_false(enclosed("R\"[raw]\" + value", 12L))
+ expect_false(enclosed("R'{raw}' + value", 12L))
+})
diff --git a/tests/testthat/test-references.R b/tests/testthat/test-references.R
index cdfc439b..c623e361 100644
--- a/tests/testthat/test-references.R
+++ b/tests/testthat/test-references.R
@@ -238,3 +238,66 @@ test_that("Find References in Rmarkdown works", {
result <- client %>% respond_references(single_file, c(6, 0), retry = FALSE)
expect_length(result, 0)
})
+
+test_that("Reference index excludes members and resolves qualified calls", {
+ uri <- "file:///reference-index.R"
+ content <- c(
+ "outer <- function(argument) {",
+ " local <- argument",
+ " object$member",
+ " base::mean(local)",
+ "}"
+ )
+ parsed <- parse_document(uri, content)
+ index <- parsed$reference_index
+
+ expect_false("member" %in% index$name)
+ mean_index <- which(index$name == "mean")
+ expect_length(mean_index, 1L)
+ expect_true(index$qualified_call[[mean_index]])
+ expect_equal(index$call_package[[mean_index]], "base")
+ expect_equal(index$definition_key[[mean_index]], "package:base:mean")
+
+ local_index <- which(index$name == "local")
+ expect_true(length(local_index) >= 2L)
+ expect_true(all(startsWith(index$definition_key[local_index], "local:")))
+
+ expect_null(reference_key_at(NULL, list(row = 0L, col = 0L), "x"))
+ expect_null(reference_key_at(index, list(row = 99L, col = 0L), "x"))
+})
+
+test_that("References fall back to XML when no occurrence index exists", {
+ content <- c(
+ "target <- function() 1",
+ "caller <- function() { target(); target() }"
+ )
+ uri <- "file:///legacy-references.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(...) parse_data
+ workspace$get_definition <- function(...) NULL
+
+ reply <- references_reply(
+ 1L, uri, workspace, document, list(row = 0L, col = 1L)
+ )
+
+ expect_length(reply$result, 3L)
+ expect_true(all(vapply(reply$result, function(item) item$uri == uri,
+ logical(1L))))
+ expect_equal(
+ map_int(reply$result, c("range", "start", "line")),
+ c(0L, 1L, 1L)
+ )
+ expect_equal(
+ map_int(reply$result, c("range", "start", "character")),
+ c(0L, 23L, 33L)
+ )
+})
diff --git a/tests/testthat/test-semantic-tokens.R b/tests/testthat/test-semantic-tokens.R
index a17ee63b..dd9e98cb 100644
--- a/tests/testthat/test-semantic-tokens.R
+++ b/tests/testthat/test-semantic-tokens.R
@@ -146,3 +146,237 @@ test_that("Semantic tokens contain expected types", {
token_count <- length(result$data) %/% 5
expect_true(token_count > 0)
})
+
+test_that("Semantic parse data handles UTF-16 and multiline tokens", {
+ astral <- intToUtf8(0x10400)
+ content <- c(
+ paste0('label <- "', astral, '"'),
+ 'description <- "first',
+ 'second"',
+ "fn <- function(argument) argument + 1L"
+ )
+ parsed <- parse(text = content, keep.source = TRUE)
+ data <- utils::getParseData(parsed, includeText = TRUE)
+
+ semantic <- semantic_parse_data(data, content)
+
+ expect_gt(length(semantic$lines), 0L)
+ expect_identical(length(semantic$encoded), length(semantic$lines) * 5L)
+ expect_true(all(diff(semantic$lines) >= 0L))
+ string_rows <- which(semantic$types == SemanticTokenTypes$string)
+ expect_true(all(c(0L, 1L, 2L) %in% semantic$lines[string_rows]))
+ astral_string <- which(
+ semantic$lines == 0L & semantic$types == SemanticTokenTypes$string
+ )
+ expect_equal(semantic$lengths[astral_string], 4L)
+
+ expect_identical(
+ semantic_parse_data(NULL, content),
+ empty_semantic_data()
+ )
+ expect_identical(
+ semantic_parse_data(data[!data$terminal, , drop = FALSE], content),
+ empty_semantic_data()
+ )
+})
+
+test_that("Semantic ranges select overlapping tokens and re-encode them", {
+ fixture <- provider_fixture(c("alpha <- 1", "beta <- alpha", "gamma <- 3"))
+ data <- fixture$document$parse_data$semantic_data
+
+ selected <- semantic_data_for_range(data, list(
+ start = list(line = 1L, character = 1L),
+ end = list(line = 2L, character = 0L)
+ ))
+ expect_true(length(selected$lines) > 0L)
+ expect_true(all(selected$lines == 1L))
+ expect_identical(length(selected$encoded), length(selected$lines) * 5L)
+
+ empty <- semantic_data_for_range(data, list(
+ start = list(line = 20L, character = 0L),
+ end = list(line = 21L, character = 0L)
+ ))
+ expect_identical(empty, empty_semantic_data())
+ expect_identical(
+ semantic_data_for_range(NULL, list()),
+ empty_semantic_data()
+ )
+})
+
+test_that("Semantic providers use cached data and legacy fallbacks", {
+ uri <- "file:///semantic-cache.R"
+ document <- Document$new(uri, version = 1L, content = "value <- 1")
+ semantic_data <- list(
+ lines = c(0L, 1L),
+ cols = c(0L, 2L),
+ lengths = c(5L, 3L),
+ types = c(SemanticTokenTypes$variable, SemanticTokenTypes$number),
+ modifiers = c(0L, 0L),
+ encoded = as.integer(c(0, 0, 5, 8, 0, 1, 2, 3, 9, 0))
+ )
+ parse_data <- list(
+ version = 1L,
+ semantic_data = semantic_data,
+ content_hash = "current"
+ )
+ workspace <- new.env(parent = baseenv())
+ workspace$parse_cache <- collections::dict()
+ workspace$get_parse_data <- function(...) parse_data
+
+ legend <- get_semantic_tokens_legend()
+ expect_identical(legend$tokenTypes, names(SemanticTokenTypes))
+ expect_identical(legend$tokenModifiers, names(SemanticTokenModifiers))
+
+ cached <- extract_semantic_tokens(uri, workspace, document)
+ expect_length(cached, 2L)
+ ranged <- extract_semantic_tokens(
+ uri, workspace, document,
+ range = range(position(0L, 0L), position(1L, 0L))
+ )
+ expect_length(ranged, 1L)
+
+ parse_data$semantic_data <- empty_semantic_data()
+ expect_identical(
+ extract_semantic_tokens(uri, workspace, document),
+ list()
+ )
+
+ parse_data <- list(
+ version = 1L,
+ semantic_data = NULL,
+ xml_doc = NULL,
+ content_hash = "current"
+ )
+ expect_identical(
+ semantic_tokens_full_reply(1L, uri, workspace, document)$result$data,
+ integer()
+ )
+ request_range <- range(position(0L, 0L), position(1L, 0L))
+ expect_identical(
+ semantic_tokens_range_reply(
+ 2L, uri, workspace, document, request_range
+ )$result$data,
+ integer()
+ )
+ expect_identical(
+ semantic_tokens_delta_reply(
+ 3L, uri, workspace, document, "missing"
+ )$result$data,
+ integer()
+ )
+
+ parse_data$semantic_data <- semantic_data
+ delta <- semantic_tokens_delta_reply(
+ 4L, uri, workspace, document, "missing"
+ )
+ expect_identical(delta$result$resultId, "current")
+ expect_identical(delta$result$data, semantic_data$encoded)
+})
+
+test_that("Semantic token types cover every parser token category", {
+ cases <- c(
+ SYMBOL = SemanticTokenTypes$variable,
+ SYMBOL_FUNCTION_CALL = SemanticTokenTypes[["function"]],
+ SYMBOL_FORMALS = SemanticTokenTypes$parameter,
+ SYMBOL_PACKAGE = SemanticTokenTypes$namespace,
+ FUNCTION = SemanticTokenTypes$keyword,
+ KEYWORD = SemanticTokenTypes$keyword,
+ NUM_CONST = SemanticTokenTypes$number,
+ INT_CONST = SemanticTokenTypes$number,
+ FLOAT_CONST = SemanticTokenTypes$number,
+ STRING = SemanticTokenTypes$string,
+ STR_CONST = SemanticTokenTypes$string,
+ COMMENT = SemanticTokenTypes$comment,
+ LEFT_ASSIGN = SemanticTokenTypes$operator,
+ RIGHT_ASSIGN = SemanticTokenTypes$operator,
+ EQ_ASSIGN = SemanticTokenTypes$operator,
+ `OP-DOLLAR` = SemanticTokenTypes$operator,
+ `OP-PIPE` = SemanticTokenTypes$operator,
+ OP = SemanticTokenTypes$operator,
+ `OP-LAMBDA` = SemanticTokenTypes$keyword,
+ UNKNOWN = SemanticTokenTypes$variable
+ )
+
+ actual <- vapply(names(cases), get_token_type, integer(1L))
+ expect_identical(unname(actual), unname(as.integer(cases)))
+})
+
+test_that("Legacy XML semantic extraction handles ranges and declarations", {
+ uri <- "file:///legacy-semantic.R"
+ content <- c(
+ "fn <- function(argument) {",
+ " value <- argument + 1L",
+ " value",
+ "}"
+ )
+ parsed <- parse(text = content, keep.source = TRUE)
+ xdoc <- xml2::read_xml(xmlparsedata::xml_parse_data(parsed))
+ workspace <- list(get_parse_data = function(request_uri) {
+ expect_identical(request_uri, uri)
+ list(xml_doc = xdoc, semantic_data = NULL)
+ })
+ document <- Document$new(uri, version = 1L, content = content)
+
+ tokens <- extract_semantic_tokens(uri, workspace, document)
+ expect_gt(length(tokens), 0L)
+ parameter <- Filter(function(token) {
+ token$tokenType == SemanticTokenTypes$parameter
+ }, tokens)
+ expect_true(any(vapply(parameter, function(token) {
+ token$tokenModifiers != 0L
+ }, logical(1L))))
+
+ ranged <- extract_semantic_tokens(
+ uri, workspace, document,
+ range = range(position(0L, 0L), position(1L, 0L))
+ )
+ expect_true(length(ranged) > 0L)
+ expect_true(all(vapply(ranged, function(token) token$line <= 1L, logical(1L))))
+
+ no_xml <- list(get_parse_data = function(...) list(xml_doc = NULL))
+ expect_identical(
+ extract_semantic_tokens(uri, no_xml, document),
+ list()
+ )
+})
+
+test_that("Semantic encoding sorts tokens and supports empty results", {
+ tokens <- list(
+ list(line = 2L, col = 0L, length = 1L,
+ tokenType = SemanticTokenTypes$number, tokenModifiers = 0L),
+ list(line = 0L, col = 4L, length = 3L,
+ tokenType = SemanticTokenTypes$variable, tokenModifiers = 0L),
+ list(line = 0L, col = 0L, length = 2L,
+ tokenType = SemanticTokenTypes$parameter, tokenModifiers = 1L)
+ )
+
+ encoded <- encode_semantic_tokens(tokens)$data
+ matrix_data <- matrix(encoded, ncol = 5L, byrow = TRUE)
+ expect_identical(matrix_data[, 1L], c(0L, 0L, 2L))
+ expect_identical(matrix_data[, 2L], c(0L, 4L, 0L))
+ expect_identical(encode_semantic_tokens(list())$data, integer())
+})
+
+test_that("Semantic deltas handle equality, insertion, and deletion", {
+ token_a <- as.integer(c(0, 0, 1, 8, 0))
+ token_b <- as.integer(c(1, 0, 1, 8, 0))
+ token_c <- as.integer(c(1, 2, 1, 8, 0))
+
+ expect_identical(semantic_token_delta(token_a, token_a), list())
+
+ inserted <- semantic_token_delta(
+ c(token_a, token_c),
+ c(token_a, token_b, token_c)
+ )[[1L]]
+ expect_equal(inserted$start, 5L)
+ expect_equal(inserted$deleteCount, 0L)
+ expect_identical(inserted$data, token_b)
+
+ deleted <- semantic_token_delta(
+ c(token_a, token_b, token_c),
+ c(token_a, token_c)
+ )[[1L]]
+ expect_equal(deleted$start, 5L)
+ expect_equal(deleted$deleteCount, 5L)
+ expect_null(deleted$data)
+})
diff --git a/tests/testthat/test-settings-log.R b/tests/testthat/test-settings-log.R
new file mode 100644
index 00000000..cdb25736
--- /dev/null
+++ b/tests/testthat/test-settings-log.R
@@ -0,0 +1,116 @@
+test_that("Settings combine defaults, options, and workspace values", {
+ settings <- Settings$new()
+ expect_false(settings$get("debug"))
+ expect_equal(settings$get("max_completions"), 200)
+ expect_null(settings$get("unknown"))
+ expect_identical(settings$set("debug", TRUE), settings)
+ expect_true(settings$get("debug"))
+
+ withr::local_options(list(
+ languageserver.debug = FALSE,
+ languageserver.max_completions = 25L
+ ))
+ settings$update_from_options()
+ expect_false(settings$get("debug"))
+ expect_equal(settings$get("max_completions"), 25L)
+
+ settings$update_from_workspace(list(
+ debug = TRUE,
+ max_completions = 50L,
+ parse_delay = 0.01
+ ))
+ expect_false(settings$get("debug"))
+ expect_equal(settings$get("max_completions"), 25L)
+ expect_equal(settings$get("parse_delay"), 0.01)
+})
+
+test_that("Log serialization handles scalars, collections, and conditions", {
+ expect_equal(to_string(), "\n")
+ expect_equal(to_string("message", 2L), "message 2\n")
+ expect_equal(to_string(character()), "\n")
+ expect_match(to_string(c("a", "b")), '"a"')
+ expect_match(to_string(list(value = 1L)), '"value"')
+
+ condition <- simpleError("broken")
+ expect_match(to_string(condition), "broken")
+
+ environment_value <- new.env(parent = emptyenv())
+ environment_value$value <- 1L
+ expect_match(to_string(environment_value), "environment")
+})
+
+test_that("Logger writes at the configured severity thresholds", {
+ path <- withr::local_tempfile()
+ old <- list(
+ debug = lsp_settings$get("debug"),
+ trace = lsp_settings$get("trace"),
+ log_file = lsp_settings$get("log_file")
+ )
+ withr::defer({
+ lsp_settings$set("debug", old$debug)
+ lsp_settings$set("trace", old$trace)
+ lsp_settings$set("log_file", old$log_file)
+ })
+ lsp_settings$set("log_file", path)
+ lsp_settings$set("debug", FALSE)
+ lsp_settings$set("trace", FALSE)
+
+ logger$info("hidden info")
+ logger$trace("hidden trace")
+ logger$error("visible error")
+ expect_match(readLines(path), "visible error")
+
+ lsp_settings$set("debug", TRUE)
+ logger$info("visible info")
+ logger$trace("still hidden")
+ lsp_settings$set("trace", TRUE)
+ logger$trace("visible trace")
+
+ output <- readLines(path)
+ expect_true(any(grepl("visible info", output, fixed = TRUE)))
+ expect_true(any(grepl("visible trace", output, fixed = TRUE)))
+ expect_false(any(grepl("hidden", output, fixed = TRUE)))
+})
+
+test_that("log_write accepts both file paths and connections", {
+ path <- withr::local_tempfile()
+ log_write("first", log_file = path)
+
+ connection <- file(path, open = "at")
+ withr::defer(close(connection))
+ log_write("second", log_file = connection)
+
+ output <- readLines(path)
+ expect_true(any(grepl("first", output, fixed = TRUE)))
+ expect_true(any(grepl("second", output, fixed = TRUE)))
+})
+
+test_that("new loggers exercise default and enabled output routes", {
+ old <- list(
+ debug = lsp_settings$get("debug"),
+ trace = lsp_settings$get("trace"),
+ log_file = lsp_settings$get("log_file")
+ )
+ withr::defer({
+ lsp_settings$set("debug", old$debug)
+ lsp_settings$set("trace", old$trace)
+ lsp_settings$set("log_file", old$log_file)
+ })
+
+ fallback <- capture.output(log_write("fallback"), type = "message")
+ expect_match(paste(fallback, collapse = "\n"), "fallback")
+
+ path <- withr::local_tempfile()
+ lsp_settings$set("log_file", path)
+ test_logger <- Logger$new()
+ test_logger$error("error route")
+ lsp_settings$set("debug", TRUE)
+ test_logger$info("info route")
+ lsp_settings$set("trace", TRUE)
+ test_logger$trace("trace route")
+
+ output <- paste(readLines(path), collapse = "\n")
+ expect_match(output, "error route")
+ expect_match(output, "info route")
+ expect_match(output, "trace route")
+})
diff --git a/tests/testthat/test-signature.R b/tests/testthat/test-signature.R
index f2ed55c3..501024b2 100644
--- a/tests/testthat/test-signature.R
+++ b/tests/testthat/test-signature.R
@@ -274,3 +274,115 @@ test_that("activeParameter handles ... at different positions", {
retry_when = function(result) length(result) == 0 || length(result$signatures) == 0)
expect_equal(result$activeParameter, 0) # Should stick to ... (index 0)
})
+
+test_that("Signature parameter parsing respects nested defaults and quotes", {
+ signature <- paste0(
+ "fun(alpha, beta = list(1, 2), gamma = ",
+ "c('a,b', \"c,d\"), `odd name` = { 1, 2 }, ...)"
+ )
+
+ expect_identical(
+ extract_parameter_names(signature),
+ c("alpha", "beta", "gamma", "`odd name`", "...")
+ )
+ expect_identical(extract_parameter_names("not a signature"), character())
+ expect_identical(extract_parameter_names("empty()"), character())
+
+ parameters <- parse_signature_parameters(signature)
+ expect_length(parameters, 5L)
+ labels <- vapply(parameters, function(parameter) {
+ start <- parameter$label[[1L]] + 1L
+ end <- parameter$label[[2L]]
+ substr(signature, start, end)
+ }, character(1L))
+ expect_identical(
+ labels,
+ c(
+ "alpha", "beta = list(1, 2)",
+ "gamma = c('a,b', \"c,d\")", "`odd name` = { 1, 2 }", "..."
+ )
+ )
+ expect_identical(parse_signature_parameters("missing"), list())
+ expect_identical(parse_signature_parameters("empty( )"), list())
+})
+
+test_that("Active parameter detection ignores nested and quoted commas", {
+ signature <- "fun(first, second, third, ..., named = NULL)"
+ cases <- list(
+ list("fun(list(1, 2), ", 1L),
+ list("fun('a,b', ", 1L),
+ list('fun("a,\\\"b", ', 1L),
+ list("fun(first = 1, named = ", 4L),
+ list("fun(1, unknown = ", 1L),
+ list("fun(1, 2, 3, 4, ", 3L),
+ list("fun(1, # comment, ignored", 1L)
+ )
+
+ for (case in cases) {
+ content <- case[[1L]]
+ actual <- detect_active_parameter(
+ content, 0L, 3L, 0L, nchar(content), signature
+ )
+ expect_equal(actual, case[[2L]])
+ }
+
+ expect_equal(
+ detect_active_parameter(c("fun(", NA_character_), 0L, 3L, 1L, 0L),
+ 0L
+ )
+ expect_equal(
+ detect_active_parameter("fun(", 5L, 0L, 6L, 0L),
+ 0L
+ )
+})
+
+test_that("Signature reply resolves local documented functions", {
+ content <- c(
+ "#' Add values",
+ "#' @param first First value.",
+ "#' @param second Second value.",
+ "add_values <- function(first, second = list(1, 2)) first + second",
+ "add_values(first = 1, second = 2)"
+ )
+ fixture <- provider_fixture(content)
+ reply <- signature_reply(
+ 1L, fixture$uri, fixture$workspace, fixture$document,
+ list(row = 4L, col = nchar(content[[5L]]) - 2L)
+ )
+
+ expect_length(reply$result$signatures, 1L)
+ expect_match(reply$result$signatures[[1L]]$label, "add_values\\(first")
+ expect_match(
+ reply$result$signatures[[1L]]$documentation$value,
+ "Add values"
+ )
+ expect_equal(reply$result$activeSignature, 0L)
+ expect_equal(reply$result$activeParameter, 1L)
+})
+
+test_that("Signature reply falls back to workspace metadata", {
+ uri <- "file:///external-signature.R"
+ document <- Document$new(uri, content = "external(value = ")
+ workspace <- list(
+ get_parse_data = function(...) list(xml_doc = NULL),
+ get_signature = function(symbol, package, exported_only) {
+ expect_equal(symbol, "external")
+ expect_true(exported_only)
+ "external(value, ..., option = TRUE)"
+ },
+ get_documentation = function(...) list(
+ description = "An external function."
+ )
+ )
+ reply <- signature_reply(
+ 1L, uri, workspace, document,
+ list(row = 0L, col = nchar(document$content[[1L]]))
+ )
+
+ expect_length(reply$result$signatures, 1L)
+ expect_equal(
+ reply$result$signatures[[1L]]$documentation$value,
+ "An external function."
+ )
+ expect_equal(reply$result$activeParameter, 0L)
+})
diff --git a/tests/testthat/test-symbol.R b/tests/testthat/test-symbol.R
index 803f83d1..24be0db4 100644
--- a/tests/testthat/test-symbol.R
+++ b/tests/testthat/test-symbol.R
@@ -36,6 +36,66 @@ test_that("Document Symbol works", {
)
})
+test_that("document symbol kinds cover scalar and class values", {
+ types <- c(
+ "logical", "integer", "double", "complex", "character", "array",
+ "list", "function", "NULL", "class", "R6", "S4", "RefClass",
+ "unknown"
+ )
+ kinds <- vapply(types, get_document_symbol_kind, numeric(1L))
+
+ expect_equal(kinds[["logical"]], SymbolKind$Boolean)
+ expect_equal(kinds[["integer"]], SymbolKind$Number)
+ expect_equal(kinds[["complex"]], SymbolKind$Number)
+ expect_equal(kinds[["character"]], SymbolKind$String)
+ expect_equal(kinds[["array"]], SymbolKind$Array)
+ expect_equal(kinds[["list"]], SymbolKind$Struct)
+ expect_equal(kinds[["function"]], SymbolKind$Function)
+ expect_equal(kinds[["NULL"]], SymbolKind$Null)
+ expect_equal(kinds[["R6"]], SymbolKind$Class)
+ expect_equal(kinds[["unknown"]], SymbolKind$Field)
+ expect_equal(get_document_symbol_kind(c("a", "b")), SymbolKind$Field)
+})
+
+test_that("hierarchical symbols attempt member extraction for classes", {
+ fixture <- provider_fixture(c(
+ "# Main ----",
+ "Widget <- 1"
+ ))
+ fixture$workspace$get_definitions_for_uri <- function(...) {
+ list(Widget = list(
+ type = "R6",
+ range = range(position(1L, 0L), position(1L, 11L))
+ ))
+ }
+ reply <- document_symbol_reply(
+ 1L,
+ fixture$uri,
+ fixture$workspace,
+ fixture$document,
+ list(hierarchicalDocumentSymbolSupport = TRUE)
+ )
+
+ expect_true(any(vapply(
+ reply$result,
+ function(item) identical(item$name, "Widget"),
+ logical(1L)
+ )))
+
+ flat <- document_symbol_reply(
+ 2L,
+ fixture$uri,
+ fixture$workspace,
+ fixture$document,
+ list(hierarchicalDocumentSymbolSupport = FALSE)
+ )
+ expect_true(any(vapply(
+ flat$result,
+ function(item) identical(item$name, "Main"),
+ logical(1L)
+ )))
+})
+
test_that("Recognize symbols created by delayedAssign/assign/makeActiveBinding", {
skip_on_cran()
client <- language_client()
diff --git a/tests/testthat/test-type-hierarchy-parsing.R b/tests/testthat/test-type-hierarchy-parsing.R
index fb2dd763..d19bfb2f 100644
--- a/tests/testthat/test-type-hierarchy-parsing.R
+++ b/tests/testthat/test-type-hierarchy-parsing.R
@@ -63,3 +63,224 @@ test_that("RefClass hierarchy parsing handles named arguments", {
)
expect_setequal(map_chr(members, "name"), c("name", "metadata", "greet"))
})
+
+test_that("R6 hierarchy parsing finds inheritance and real members", {
+ code <- c(
+ 'Base <- R6Class("Base", public = list(base_field = 1))',
+ paste0(
+ 'Child <- R6::R6Class("Child", inherit = Base, ',
+ 'public = list(value = 1, run = function(x) { list(nested = x) }), ',
+ 'private = list(secret = 2, hide = function() secret), ',
+ 'active = list(ignored = function() value), cloneable = TRUE)'
+ ),
+ 'Sibling <- R6Class("Sibling", inherit = Base, public = list())'
+ )
+ document <- Document$new("file:///r6.R", content = code)
+ xdoc <- parse_type_hierarchy_xdoc(code)
+
+ assignment <- detect_r6class(xdoc, "Child", document, document$uri)
+ expect_equal(assignment$name, "Child")
+ expect_equal(assignment$classType, "R6")
+
+ string_definition <- detect_r6class(xdoc, "Sibling", document, document$uri)
+ expect_equal(string_definition$name, "Sibling")
+
+ supertypes <- find_r6_supertypes(document, xdoc, "Child", document$uri)
+ expect_equal(map_chr(supertypes, "name"), "Base")
+ expect_equal(supertypes[[1L]]$classType, "R6")
+
+ subtypes <- find_r6_subtypes(document, xdoc, "Base", document$uri)
+ expect_setequal(map_chr(subtypes, "name"), c("Child", "Sibling"))
+
+ members <- extract_r6_members(
+ document, xdoc, list(name = "Child", type = "R6")
+ )
+ expect_setequal(
+ map_chr(members, "name"),
+ c("value", "run", "secret", "hide")
+ )
+ expect_false("nested" %in% map_chr(members, "name"))
+ expect_setequal(
+ map_chr(members, "detail"),
+ c("public", "private")
+ )
+ kinds <- setNames(map_int(members, "kind"), map_chr(members, "name"))
+ expect_equal(kinds[["value"]], SymbolKind$Field)
+ expect_equal(kinds[["run"]], SymbolKind$Method)
+
+ expect_equal(
+ extract_class_members(
+ document, xdoc, list(name = "Child", type = "R6")
+ ),
+ members
+ )
+})
+
+test_that("S3 and setMethod definitions are detected without false positives", {
+ code <- c(
+ "print.widget <- function(x, ...) x",
+ 'setMethod("show", "Special", function(object) object)',
+ "plain_name <- 1"
+ )
+ document <- Document$new("file:///methods.R", content = code)
+ xdoc <- parse_type_hierarchy_xdoc(code)
+
+ s3_scopes <- xdoc_find_enclosing_scopes(xdoc, 1L, 2L, top = TRUE)
+ s3 <- detect_s3class(s3_scopes, "print.widget", document, document$uri)
+ expect_equal(s3$name, "widget")
+ expect_equal(s3$classType, "S3")
+
+ method_scopes <- xdoc_find_enclosing_scopes(xdoc, 2L, 20L, top = TRUE)
+ s4 <- detect_s3class(method_scopes, "Special", document, document$uri)
+ expect_equal(s4$name, "Special")
+ expect_equal(s4$classType, "S4")
+
+ expect_null(detect_s3class(xdoc, "plain_name", document, document$uri))
+ expect_identical(
+ find_s3_supertypes(document, xdoc, "widget", document$uri),
+ list()
+ )
+ expect_identical(
+ find_s3_subtypes_child(document, xdoc, "widget", document$uri),
+ list()
+ )
+})
+
+test_that("Type detection uses the token under the cursor", {
+ code <- c(
+ 'Parent <- R6Class("Parent")',
+ 'Child <- R6Class("Child", inherit = Parent)',
+ "Child"
+ )
+ uri <- "file:///detected-r6.R"
+ document <- Document$new(uri, content = code)
+ xdoc <- parse_type_hierarchy_xdoc(code)
+ workspace <- list(get_parse_data = function(request_uri) {
+ expect_identical(request_uri, uri)
+ list(xml_doc = xdoc)
+ })
+
+ detected <- detect_type_definition(
+ uri, workspace, document, list(row = 1L, col = 1L), "Child"
+ )
+ expect_equal(detected$name, "Child")
+ expect_equal(detected$classType, "R6")
+
+ no_parse <- list(get_parse_data = function(...) list(xml_doc = NULL))
+ expect_null(detect_type_definition(
+ uri, no_parse, document, list(row = 1L, col = 1L), "Child"
+ ))
+ expect_null(detect_type_definition(
+ uri, workspace, document, list(row = 1L, col = 6L), ""
+ ))
+
+ fallback <- detect_type_definition(
+ uri, workspace, document, list(row = 2L, col = 2L), "Child"
+ )
+ expect_equal(fallback$name, "Child")
+ expect_equal(fallback$classType, "R6")
+ expect_null(detect_type_definition(
+ uri, workspace, document, list(row = 99L, col = 0L), "Child"
+ ))
+})
+
+test_that("Type detection falls through to S3 definitions and null results", {
+ fixture <- provider_fixture(c(
+ "print.widget <- function(x) x",
+ "plain_name <- 1"
+ ))
+ s3 <- detect_type_definition(
+ fixture$uri,
+ fixture$workspace,
+ fixture$document,
+ list(row = 0L, col = 2L),
+ "print.widget"
+ )
+ expect_equal(s3$name, "widget")
+ expect_equal(s3$classType, "S3")
+
+ expect_null(detect_type_definition(
+ fixture$uri,
+ fixture$workspace,
+ fixture$document,
+ list(row = 1L, col = 2L),
+ "plain_name"
+ ))
+
+ no_xml <- list(
+ documents = fixture$workspace$documents,
+ type_hierarchy_cache = collections::dict(),
+ get_parse_data = function(...) list(xml_doc = NULL)
+ )
+ expect_length(find_type_supertypes(no_xml, list(
+ name = "widget",
+ uri = fixture$uri,
+ classType = "S3"
+ )), 0L)
+})
+
+test_that("R6 hierarchy accepts quoted inheritance", {
+ code <- c(
+ 'Base <- R6Class("Base")',
+ 'Child <- R6Class("Child", inherit = "Base")'
+ )
+ document <- Document$new("file:///quoted-r6.R", content = code)
+ xdoc <- parse_type_hierarchy_xdoc(code)
+
+ supertypes <- find_r6_supertypes(
+ document, xdoc, "Child", document$uri
+ )
+ expect_equal(map_chr(supertypes, "name"), "Base")
+})
+
+test_that("type hierarchy caches empty and S3 hierarchy results", {
+ fixture <- provider_fixture("print.widget <- function(x) x")
+ fixture$workspace$type_hierarchy_cache <- collections::dict()
+ definition <- list(
+ name = "widget",
+ uri = fixture$uri,
+ classType = "S3"
+ )
+
+ expect_length(find_type_supertypes(fixture$workspace, definition), 0L)
+ cache_size <- fixture$workspace$type_hierarchy_cache$size()
+ expect_length(find_type_supertypes(fixture$workspace, definition), 0L)
+ expect_equal(fixture$workspace$type_hierarchy_cache$size(), cache_size)
+
+ missing <- list(
+ documents = collections::dict(),
+ type_hierarchy_cache = collections::dict()
+ )
+ missing$documents$set(definition$uri, NULL)
+ expect_length(find_type_supertypes(missing, definition), 0L)
+
+ fixture$workspace$type_hierarchy_cache$set(
+ paste("sub", fixture$uri, "S3", "widget", sep = "\r"),
+ list(list(name = "cached"))
+ )
+ expect_equal(
+ find_type_subtypes(fixture$workspace, definition)[[1L]]$name,
+ "cached"
+ )
+})
+
+test_that("Element ranges reject absent or incomplete parse nodes", {
+ document <- Document$new("file:///ranges.R", content = '"quoted"')
+ xdoc <- parse_type_hierarchy_xdoc('"quoted"')
+ string <- xml2::xml_find_first(xdoc, "//STR_CONST")
+
+ expect_equal(
+ get_element_range(document, string),
+ range(position(0L, 1L), position(0L, 7L))
+ )
+ expect_null(get_element_range(document, xml2::xml_missing()))
+
+ incomplete <- xml2::read_xml("x")
+ expect_null(get_element_range(document, incomplete))
+ expect_null(extract_class_members(
+ document, xdoc, list(name = "Anything", type = "unknown")
+ ))
+ expect_null(extract_class_members(
+ document, xdoc, list(name = "Anything")
+ ))
+})
diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
index 24cbdf8a..a724a88d 100644
--- a/tests/testthat/test-utils.R
+++ b/tests/testthat/test-utils.R
@@ -40,3 +40,209 @@ test_that("indexed enclosing scope lookup preserves results", {
expect_equal(xml2::xml_path(actual), xml2::xml_path(expected))
})
+
+test_that("stack-aware errors retain printable call information", {
+ fail <- function() stop("failure from helper")
+ captured <- tryCatchStack(fail(), error = identity)
+
+ expect_s3_class(captured, "errorWithStack")
+ expect_match(conditionMessage(captured), "failure from helper")
+ output <- capture.output(print.errorWithStack(captured))
+ expect_true(any(grepl("Error: failure from helper", output, fixed = TRUE)))
+ if (length(captured$calls)) {
+ expect_true(any(grepl("Stack trace:", output, fixed = TRUE)))
+ }
+ expect_match(capture_print(list(value = 1L)), "value")
+})
+
+test_that("expression types distinguish language object categories", {
+ cases <- list(
+ list(quote(function(x) x), "function"),
+ list(quote(c(1, 2)), "array"),
+ list(quote(matrix(1)), "array"),
+ list(quote(list(1)), "list"),
+ list(quote(R6::R6Class("Class")), "R6"),
+ list(quote(methods::setClass("Class")), "S4"),
+ list(quote(methods::setRefClass("Class")), "RefClass"),
+ list(quote(custom_call()), "variable"),
+ list(quote(name), "symbol"),
+ list(1L, "integer")
+ )
+
+ actual <- vapply(cases, function(case) get_expr_type(case[[1L]]), character(1L))
+ expected <- vapply(cases, `[[`, character(1L), 2L)
+ expect_identical(actual, expected)
+})
+
+test_that("URI helpers handle files, notebooks, Unicode, and empty inputs", {
+ expect_identical(uri_escape_unicode(character()), character())
+ expect_match(uri_escape_unicode("file:///tmp/a b.R"), "a%20b.R", fixed = TRUE)
+ expect_identical(path_from_uri(character()), character())
+ expect_identical(path_to_uri(character()), character())
+ expect_equal(path_from_uri("untitled:Untitled-1"), "")
+
+ path <- file.path(tempdir(), paste0("space ", intToUtf8(0x4f62), ".R"))
+ expect_equal(
+ normalizePath(
+ path_from_uri(path_to_uri(path)),
+ winslash = "/",
+ mustWork = FALSE
+ ),
+ normalizePath(path.expand(path), winslash = "/", mustWork = FALSE)
+ )
+ expect_equal(
+ path_from_uri("vscode-notebook-cell:/tmp/notebook.ipynb#cell-1"),
+ "/tmp/notebook.ipynb"
+ )
+ expect_equal(
+ path_from_uri(
+ "vscode-notebook-cell://wsl+ubuntu/tmp/notebook.ipynb#cell-1"
+ ),
+ "/tmp/notebook.ipynb"
+ )
+})
+
+test_that("path helpers find package roots and restore working directories", {
+ original <- getwd()
+ package_root <- normalizePath(withr::local_tempdir())
+ writeLines(
+ c("Package: pathfixture", "Version: 0.0.1"),
+ file.path(package_root, "DESCRIPTION")
+ )
+ dir.create(file.path(package_root, "R"))
+ expect_false(path_has_parent(package_root, NULL))
+ expect_true(path_has_parent(file.path(package_root, "R"), package_root))
+ expect_true(is_directory(package_root))
+ expect_false(is_directory(file.path(package_root, "does-not-exist")))
+ expect_equal(
+ find_package(file.path(package_root, "R")),
+ package_root
+ )
+ expect_null(find_package(file.path(package_root, "does-not-exist")))
+
+ empty_dir <- withr::local_tempdir()
+ expect_null(find_package(empty_dir))
+ expect_equal(getwd(), original)
+ expect_equal(
+ normalizePath(with_wd(empty_dir, getwd())),
+ normalizePath(empty_dir)
+ )
+ expect_equal(getwd(), original)
+ expect_equal(with_wd(NULL, getwd()), original)
+
+ uri <- path_to_uri(file.path(empty_dir, "file.R"))
+ expect_equal(get_root_path_for_uri(uri, original), original)
+ expect_equal(
+ normalizePath(
+ get_root_path_for_uri(uri, character()),
+ winslash = "/",
+ mustWork = FALSE
+ ),
+ normalizePath(empty_dir, winslash = "/", mustWork = FALSE)
+ )
+ expect_equal(get_root_path_for_uri("untitled:1", character()), original)
+})
+
+test_that("R Markdown block extraction handles empty and incomplete fences", {
+ content <- c(
+ "text",
+ "```{r}",
+ "x <- 1",
+ "```",
+ "```{R, echo=FALSE}",
+ "y <- 2",
+ "```",
+ "```{r}",
+ "unfinished <- TRUE"
+ )
+ blocks <- extract_blocks(content)
+ expect_length(blocks, 2L)
+ expect_equal(map_int(blocks, ~ .x$lines), c(3L, 6L))
+ expect_equal(map_chr(blocks, ~ .x$text), c("x <- 1", "y <- 2"))
+ expect_identical(extract_blocks(c("text", "```{r}", "```")), list())
+ expect_identical(extract_blocks("plain text"), list())
+})
+
+test_that("small text helpers cover boundaries and throttling", {
+ calls <- 0L
+ throttled <- throttle(function(value) {
+ calls <<- calls + 1L
+ value
+ }, t = 60)
+ expect_equal(throttled("first"), "first")
+ expect_null(throttled("second"))
+ expect_equal(calls, 1L)
+
+ expect_equal(look_forward("alpha.beta + rest")$token, "alpha.beta")
+ expect_equal(look_forward("+")$token, "")
+ expect_equal(look_backward("pkg:::fun"), list(
+ full_token = "pkg:::fun", package = "pkg",
+ accessor = ":::", token = "fun"
+ ))
+ expect_equal(look_backward("object$member")$full_token, "")
+ expect_equal(look_backward("member")$full_token, "member")
+ expect_equal(na_to_empty_string(NA_character_), "")
+ expect_null(empty_string_to_null(""))
+ expect_equal(empty_string_to_null("value"), "value")
+ expect_equal(str_trunc("abcdefgh", 6L), "abc...")
+ expect_equal(str_trunc("abc", 6L), "abc")
+ expect_true(is.na(str_trunc(NA_character_, 6L)))
+})
+
+test_that("documentation helpers render roxygen and Rd structures", {
+ documentation <- convert_comment_to_documentation(c(
+ "#' Add two values",
+ "#'",
+ "#' A longer description.",
+ "#' @param x First value.",
+ "#' @param y Second value.",
+ "#' @examples add(1, 2)"
+ ))
+ expect_equal(documentation$title, "Add two values")
+ expect_match(documentation$description, "longer description")
+ expect_setequal(names(documentation$arguments), c("x", "y"))
+ expect_match(documentation$markdown, "```r", fixed = TRUE)
+
+ fallback <- convert_comment_to_documentation("# ordinary comment")
+ expect_identical(fallback, "ordinary comment")
+
+ rd <- tools::parse_Rd(
+ textConnection("\\code{x} \\R{} \\dots{}"),
+ fragment = TRUE
+ )
+ markdown <- convert_doc_string(rd)
+ expect_match(markdown, "`x`", fixed = TRUE)
+ expect_match(markdown, "**R**", fixed = TRUE)
+ expect_match(markdown, "...", fixed = TRUE)
+})
+
+test_that("help and file probes handle real text and binary data", {
+ help_file <- utils::help("mean", package = "base")
+ expect_match(get_help(help_file, "text"), "Generic function")
+ expect_match(get_help(help_file, "html"), "Arithmetic Mean")
+ expect_null(get_help(structure(character(), class = "help_files_with_topic")))
+
+ text_path <- withr::local_tempfile()
+ writeLines("plain UTF-8 text", text_path, useBytes = TRUE)
+ expect_true(is_text_file(text_path))
+
+ binary_path <- withr::local_tempfile()
+ connection <- file(binary_path, open = "wb")
+ writeBin(as.raw(c(
+ 0x89, 0x50, 0x4e, 0x47, 0x0d, 0x0a, 0x1a, 0x0a, 0x00, 0xff
+ )), connection)
+ close(connection)
+ expect_false(is_text_file(binary_path))
+
+ expect_match(format_file_size(0), "0")
+ expect_match(format_file_size(1024), "1")
+})
+
+test_that("XML lookup returns a missing node outside parsed source", {
+ xdoc <- parse_xdoc("value <- 1")
+ token <- xdoc_find_token(xdoc, line = 20L, col = 1L)
+ expect_s3_class(token, "xml_missing")
+
+ scopes <- xdoc_find_enclosing_scopes(xdoc, line = 20L, col = 1L)
+ expect_length(scopes, 0L)
+})
diff --git a/tests/testthat/test-workspace-core.R b/tests/testthat/test-workspace-core.R
new file mode 100644
index 00000000..cc6dc1cb
--- /dev/null
+++ b/tests/testthat/test-workspace-core.R
@@ -0,0 +1,129 @@
+test_that("Workspace validates caches and resolves imported namespaces", {
+ old_parse <- lsp_settings$get("parse_cache_max_mb")
+ old_diagnostics <- lsp_settings$get("diagnostics_cache_max_mb")
+ withr::defer({
+ lsp_settings$set("parse_cache_max_mb", old_parse)
+ lsp_settings$set("diagnostics_cache_max_mb", old_diagnostics)
+ })
+ lsp_settings$set("parse_cache_max_mb", NA_real_)
+ lsp_settings$set("diagnostics_cache_max_mb", -1)
+ workspace <- Workspace$new(NULL)
+
+ workspace$imported_objects$set("coverage_only_object", "base")
+ expect_equal(workspace$guess_namespace("coverage_only_object"), "base")
+ expect_null(workspace$get_namespace("coveragePackageThatDoesNotExist"))
+ expect_length(workspace$get_definitions_for_uri("file:///missing.R"), 0L)
+ expect_null(workspace$import_from_namespace_file())
+})
+
+test_that("Workspace caches rendered help", {
+ workspace <- Workspace$new(NULL)
+ old_rich <- lsp_settings$get("rich_documentation")
+ withr::defer(lsp_settings$set("rich_documentation", old_rich))
+ lsp_settings$set("rich_documentation", FALSE)
+
+ first <- workspace$get_help("mean", "base")
+ second <- workspace$get_help("mean", "base")
+ expect_false(is.null(first))
+ expect_identical(second, first)
+ expect_true(workspace$help_cache$size() >= 1L)
+})
+
+test_that("Workspace diagnostics globals include package source definitions", {
+ root <- withr::local_tempdir()
+ writeLines(c("Package: coveragefixture", "Version: 0.0.1"),
+ file.path(root, "DESCRIPTION"))
+ source_dir <- file.path(root, "R")
+ dir.create(source_dir)
+ workspace <- Workspace$new(root)
+
+ parsed <- Document$new(
+ path_to_uri(file.path(source_dir, "parsed.R")),
+ content = "global <- 1"
+ )
+ parsed$parse_data <- list(
+ nonfuncts = "global",
+ functions = list(helper = function() TRUE)
+ )
+ unparsed <- Document$new(
+ path_to_uri(file.path(source_dir, "unparsed.R")),
+ content = "ignored <- 1"
+ )
+ outside <- Document$new(
+ path_to_uri(file.path(root, "outside.R")),
+ content = "outside <- 1"
+ )
+ outside$parse_data <- list(
+ nonfuncts = "outside",
+ functions = list()
+ )
+ workspace$documents$set(parsed$uri, parsed)
+ workspace$documents$set(unparsed$uri, unparsed)
+ workspace$documents$set(outside$uri, outside)
+
+ globals <- workspace$get_diagnostics_globals()
+ expect_true(exists("global", globals, inherits = FALSE))
+ expect_true(exists("helper", globals, inherits = FALSE))
+ expect_false(exists("outside", globals, inherits = FALSE))
+ expect_identical(workspace$get_diagnostics_globals(), globals)
+})
+
+test_that("Workspace parses named NAMESPACE imports and polls recent files", {
+ root <- withr::local_tempdir()
+ writeLines(c("Package: coveragefixture", "Version: 0.0.1"),
+ file.path(root, "DESCRIPTION"))
+ writeLines(c(
+ "1",
+ "import(base, except = c(mean))",
+ "importFrom(stats, median)"
+ ), file.path(root, "NAMESPACE"))
+ workspace <- Workspace$new(root)
+
+ workspace$import_from_namespace_file()
+ expect_true("base" %in% workspace$imported_packages)
+ expect_equal(workspace$imported_objects$get("median"), "stats")
+ expect_null(workspace$poll_namespace_file())
+})
+
+test_that("workspace handlers remove folders and ignore unrelated file events", {
+ self <- new.env(parent = baseenv())
+ self$removed <- character()
+ self$remove_workspace <- function(uri) {
+ self$removed <- c(self$removed, uri)
+ }
+ workspace_did_change_workspace_folders(self, list(event = list(
+ added = list(),
+ removed = list(list(uri = "file:///removed", name = "removed"))
+ )))
+ expect_equal(self$removed, "file:///removed")
+
+ plain_root <- withr::local_tempdir()
+ package_root <- withr::local_tempdir()
+ writeLines(c("Package: handlerfixture", "Version: 0.0.1"),
+ file.path(package_root, "DESCRIPTION"))
+ dir.create(file.path(package_root, "R"))
+ plain <- Workspace$new(plain_root)
+ package <- Workspace$new(package_root)
+ open_path <- file.path(package_root, "R", "open.R")
+ writeLines("value <- 1", open_path)
+ open_document <- Document$new(path_to_uri(open_path), content = "value <- 1")
+ open_document$did_open()
+ package$documents$set(open_document$uri, open_document)
+ self$get_workspace <- function(uri) {
+ if (path_has_parent(path_from_uri(uri), package_root)) package else plain
+ }
+ self$text_sync <- function(...) stop("ignored events must not be synchronized")
+
+ workspace_did_change_watched_files(self, list(changes = list(
+ list(
+ uri = path_to_uri(file.path(plain_root, "plain.R")),
+ type = FileChangeType$Changed
+ ),
+ list(
+ uri = path_to_uri(file.path(package_root, "outside.R")),
+ type = FileChangeType$Changed
+ ),
+ list(uri = open_document$uri, type = FileChangeType$Changed)
+ )))
+ expect_true(package$documents$has(open_document$uri))
+})