From e73a2f8df66d5218c1c6e839d3f370fe73bc953c Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 30 Jul 2026 07:25:29 +0800 Subject: [PATCH 1/3] Add more tests --- R/type_hierarchy.R | 2 +- R/utils.R | 2 +- tests/testthat/test-cache.R | 17 ++ tests/testthat/test-call-hierarchy.R | 88 +++++++ tests/testthat/test-code-action.R | 134 ++++++++++ tests/testthat/test-code-lens.R | 48 ++++ tests/testthat/test-color.R | 21 ++ tests/testthat/test-completion.R | 199 ++++++++++++++ tests/testthat/test-document-core.R | 62 +++++ tests/testthat/test-formatting.R | 153 +++++++++++ tests/testthat/test-handlers-langfeatures.R | 261 +++++++++++++++++++ tests/testthat/test-handlers-textsync.R | 194 ++++++++++++++ tests/testthat/test-hover.R | 109 ++++++++ tests/testthat/test-inlay-hint.R | 118 +++++++++ tests/testthat/test-inline-value.R | 48 ++++ tests/testthat/test-interfaces.R | 87 +++++++ tests/testthat/test-langauagecilent.R | 15 ++ tests/testthat/test-languagebase.R | 116 +++++++++ tests/testthat/test-languageserver-core.R | 147 +++++++++++ tests/testthat/test-link-core.R | 19 ++ tests/testthat/test-linked-editing.R | 36 +++ tests/testthat/test-lintr.R | 122 +++++++++ tests/testthat/test-lsp-3-18.R | 8 + tests/testthat/test-native-utilities.R | 138 ++++++++++ tests/testthat/test-references.R | 63 +++++ tests/testthat/test-semantic-tokens.R | 234 +++++++++++++++++ tests/testthat/test-settings-log.R | 116 +++++++++ tests/testthat/test-signature.R | 112 ++++++++ tests/testthat/test-symbol.R | 60 +++++ tests/testthat/test-type-hierarchy-parsing.R | 221 ++++++++++++++++ tests/testthat/test-utils.R | 187 +++++++++++++ tests/testthat/test-workspace-core.R | 129 +++++++++ 32 files changed, 3264 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-document-core.R create mode 100644 tests/testthat/test-handlers-langfeatures.R create mode 100644 tests/testthat/test-handlers-textsync.R create mode 100644 tests/testthat/test-interfaces.R create mode 100644 tests/testthat/test-languagebase.R create mode 100644 tests/testthat/test-languageserver-core.R create mode 100644 tests/testthat/test-link-core.R create mode 100644 tests/testthat/test-native-utilities.R create mode 100644 tests/testthat/test-settings-log.R create mode 100644 tests/testthat/test-workspace-core.R 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..1ec1f9c3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -584,13 +584,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/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..fe82fbe6 --- /dev/null +++ b/tests/testthat/test-handlers-textsync.R @@ -0,0 +1,194 @@ +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(file.path(getwd(), "..", "..")) + 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..d6d802ca 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -40,3 +40,190 @@ 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(path_from_uri(path_to_uri(path)), path.expand(path)) + 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(file.path(original, "..", "..")) + 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(get_root_path_for_uri(uri, character()), empty_dir) + 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)) +}) From 12522aacc520a769931c6585133c80d15c9e75fc Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 30 Jul 2026 12:58:36 +0800 Subject: [PATCH 2/3] Fix package-context test fixtures --- tests/testthat/test-handlers-textsync.R | 7 ++++++- tests/testthat/test-utils.R | 7 ++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-handlers-textsync.R b/tests/testthat/test-handlers-textsync.R index fe82fbe6..a67d7a3e 100644 --- a/tests/testthat/test-handlers-textsync.R +++ b/tests/testthat/test-handlers-textsync.R @@ -176,7 +176,12 @@ test_that("didClose removes non-package documents and clears caches", { }) test_that("didClose retains documents belonging to an open package", { - package_root <- normalizePath(file.path(getwd(), "..", "..")) + 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") diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index d6d802ca..2e017647 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -97,7 +97,12 @@ test_that("URI helpers handle files, notebooks, Unicode, and empty inputs", { test_that("path helpers find package roots and restore working directories", { original <- getwd() - package_root <- normalizePath(file.path(original, "..", "..")) + 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)) From c7d144385a4265f2c70bc4344b7b0abeb08bc47f Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 30 Jul 2026 16:47:00 +0800 Subject: [PATCH 3/3] Fix Windows path handling --- R/utils.R | 13 ++++++------- R/workspace.R | 13 +++++++++++-- tests/testthat/test-utils.R | 18 ++++++++++++++++-- 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/R/utils.R b/R/utils.R index 1ec1f9c3..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("") 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-utils.R b/tests/testthat/test-utils.R index 2e017647..a724a88d 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -82,7 +82,14 @@ test_that("URI helpers handle files, notebooks, Unicode, and empty inputs", { expect_equal(path_from_uri("untitled:Untitled-1"), "") path <- file.path(tempdir(), paste0("space ", intToUtf8(0x4f62), ".R")) - expect_equal(path_from_uri(path_to_uri(path)), path.expand(path)) + 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" @@ -125,7 +132,14 @@ test_that("path helpers find package roots and restore working directories", { uri <- path_to_uri(file.path(empty_dir, "file.R")) expect_equal(get_root_path_for_uri(uri, original), original) - expect_equal(get_root_path_for_uri(uri, character()), empty_dir) + 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) })