From e32540b733ef041f753e3c5647816471f3132e86 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 29 Oct 2026 21:11:06 +0800 Subject: [PATCH 01/12] Prepare and reuse S3 method return summaries for member inference --- R/member-extraction.R | 29 +++++++++---- R/member-inference.R | 11 +++++ tests/testthat/test-member-return-dispatch.R | 44 ++++++++++++++++++++ 3 files changed, 75 insertions(+), 9 deletions(-) create mode 100644 tests/testthat/test-member-return-dispatch.R diff --git a/R/member-extraction.R b/R/member-extraction.R index a8e584ca..66f8ff8c 100644 --- a/R/member-extraction.R +++ b/R/member-extraction.R @@ -612,6 +612,12 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 for (key in index$exports) { add(key) add(unname(index$members[[key]])) + fn <- member_definition(index$definitions, key) + if (!member_head(fn, "function")) next + generic <- s3_generic_descriptor(fn) + if (!is.null(generic)) { + add(names(index$definitions)[startsWith(names(index$definitions), paste0(generic$name, "."))]) + } } types <- intersect(names(index$members), names(index$classes)) types <- types[order(vapply(index$members[types], length, integer(1L)), types)] @@ -689,7 +695,7 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 id <- if (is.null(type)) key else paste(type, key, sep = "|") # Native-backed declarative classes expose their members in the # index. Argument-dependent fields must not enter a universal summary. - value <- member_value(type = result$type, classes = result$classes) + value <- member_value(type = result$type, classes = result$classes, member_package = index$package) size <- as.numeric(utils::object.size(stats::setNames(list(value), id))) if (state$bytes + size <= max_bytes) { index$method_results[id] <- list(value) @@ -707,14 +713,19 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 } preparation_index$method_results <- index$method_results candidates <- Filter(function(item) length(item$fn[[2L]]) < 10L, candidates) - unfinished <- list() - for (item in candidates) { - if (state$remaining <= 0L || state$bytes >= max_bytes) break - if (prepare(item, 64L)) unfinished[[length(unfinished) + 1L]] <- item - } - for (item in unfinished) { - if (state$remaining <= 0L || state$bytes >= max_bytes) break - prepare(item, 2048L) + # Finish exported factories and their S3 methods before large member + # registries consume the remaining budget with their initial probes. + for (exported in c(TRUE, FALSE)) { + group <- Filter(function(item) identical(is.null(item$type), exported), candidates) + unfinished <- list() + for (item in group) { + if (state$remaining <= 0L || state$bytes >= max_bytes) break + if (prepare(item, 64L)) unfinished[[length(unfinished) + 1L]] <- item + } + for (item in unfinished) { + if (state$remaining <= 0L || state$bytes >= max_bytes) break + prepare(item, 2048L) + } } index$return_definitions <- digest::digest(index$definitions, algo = "xxhash64") invisible(NULL) diff --git a/R/member-inference.R b/R/member-inference.R index cc6aa382..55d41c73 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -790,6 +790,17 @@ member_infer <- function( if (!member_head(fn, "function")) { return(unknown) } + # S3 dispatch invokes methods directly, without the ordinary callee + # shortcut below. Reuse a proven return shape after argument matching. + summary_key <- if (is.null(self)) key else paste(self$type, key, sep = "|") + summary <- member_lookup(index$method_results, summary_key) + if (is.null(summary)) summary <- member_lookup(index$method_results, key) + if (!is.null(summary) && !isTRUE(attr(actuals, "member_open_dots"))) { + if (is.null(bind_arguments(fn, actuals, list(), defaults = FALSE))) { + return(member_value(reason = "argument_matching")) + } + return(summary) + } # Package syntax and captures are immutable. A cached invocation has # already passed matching; look it up before defaults and delegation. cache_values <- c(list(self), actuals) diff --git a/tests/testthat/test-member-return-dispatch.R b/tests/testthat/test-member-return-dispatch.R new file mode 100644 index 00000000..9ff8c071 --- /dev/null +++ b/tests/testthat/test-member-return-dispatch.R @@ -0,0 +1,44 @@ +test_that("Prepared S3 method returns retain namespace ownership and argument matching", { + code <- paste(c( + "native_box <- function(pointer) {box <- new.env(); box$step <- make_step(pointer); class(box) <- \"raw_box\"; box}", + "make_step <- function(pointer) function() native_box(.Call(\"never\", pointer))", + "adapt <- function(x) UseMethod(\"adapt\")", + "adapt.raw_box <- function(x) {box <- new.env(); box$raw <- x; class(box) <- \"public_box\"; box}", + "convert <- function(x, flag = TRUE) UseMethod(\"convert\")", + "convert.data.frame <- function(x, flag = TRUE) {copied <- lapply(x, function(column) identity(column)); adapt(native_box(.Call(\"never\", copied)))}", + "convert.list <- function(x, flag = TRUE) if(flag) adapt(native_box(NULL)) else list(other = TRUE)" + ), collapse = "\n") + scope <- new.env(parent = baseenv()) + eval(parse(text = code), scope) + index <- member_package_index(member_namespace_input(scope, package = "conversionfixture", exports = "convert")) + expect_identical(index$method_results$convert.data.frame$type, "public_box") + expect_identical(index$method_results$convert.data.frame$member_package, "conversionfixture") + expect_null(index$method_results$convert.list) + for (call in c( + 'convert(structure(list(value = 1), class = "data.frame"))', + 'convert(structure(list(value = 1), class = "data.frame"), fl = FALSE)')) { + budget <- member_request_budget() + budget$remaining <- 32L + result <- member_infer(str2lang(call), index, index$package_roots, budget = budget) + expect_identical(result$type, "public_box", info = call) + expect_false(budget$exhausted, info = call) + } + expect_identical(member_infer(quote(convert(list(value = 1), FALSE)), index, index$package_roots)$type, "list") + expect_identical(member_infer(quote(convert(structure(list(value = 1), class = "data.frame"), + flag = TRUE, flag = FALSE)), index, index$package_roots)$reason, "argument_matching") + expect_identical(member_infer(quote(convert(structure(list(value = 1), class = "data.frame"), + unknown = TRUE)), index, index$package_roots)$reason, "argument_matching") + data <- new.env(parent = baseenv()) + data$records <- data.frame(value = 1) + snapshots <- list(conversionfixture = member_index_freeze(index), + datafixture = member_index_freeze(member_package_index(member_namespace_input( + data, package = "datafixture", exports = "records")))) + content <- c("library(conversionfixture)", "converted <- convert(datafixture::records)", "converted$") + document <- Document$new("file:///conversion.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + metadata <- collections::dict() + for (package in names(snapshots)) metadata$set(package, member_index_thaw(snapshots[[package]])) + items <- member_completion(document$uri, list(member_metadata = metadata), document, + list(row = 2L, col = nchar(content[[3L]])), FALSE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), "raw") +}) From a49d8e5a5aebbc28c8d27c0cb9cecbdefe600543 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 29 Oct 2026 21:11:14 +0800 Subject: [PATCH 02/12] Cover Polars DataFrame completion before and after queries --- NEWS.md | 4 ++ .../test-polars-dataframe-completion.R | 39 +++++++++++++++++++ 2 files changed, 43 insertions(+) create mode 100644 tests/testthat/test-polars-dataframe-completion.R diff --git a/NEWS.md b/NEWS.md index f7b477c8..5760b083 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # languageserver 0.3.20 +- Preserve member completion for Polars conversions such as + `dt <- as_polars_df(iris)` and for `pl$` after calls using the converted frame. + Prepare bounded S3 method return summaries with their owning namespace. + - Avoid a server crash when completion, hover or signature help is requested inside `function()`, `if`, `for` or `while` while package metadata is loading. Report errors from queued request readiness checks without stopping the server. diff --git a/tests/testthat/test-polars-dataframe-completion.R b/tests/testthat/test-polars-dataframe-completion.R new file mode 100644 index 00000000..d74ee1ff --- /dev/null +++ b/tests/testthat/test-polars-dataframe-completion.R @@ -0,0 +1,39 @@ +test_that("Polars conversions and later roots complete within a small inference budget", { + skip_if_not_installed("polars") + snapshots <- c(list(polars = member_prepare_package("polars")), member_prepare_startup_data("datasets")) + metadata <- MemberMetadataCache$new(32 * 1024^2, max_entries = 16L) + for (package in names(snapshots)) metadata$set(package, snapshots[[package]]) + workspace <- list(member_metadata = metadata, startup_packages = "datasets") + budget_factory <- member_request_budget + testthat::local_mocked_bindings(member_request_budget = function() { + budget <- budget_factory() + budget$remaining <- 128L + budget + }, .package = "languageserver") + for (conversion in c("as_polars_df(iris)", "polars::as_polars_df(datasets::iris)", + "as_polars_df(list(value = 1))", "pl$DataFrame(iris)")) { + lines <- c("library(polars)", "", paste0("dt <- ", conversion), + "# complete before the query", + 'dt$filter(pl$col("Sepal.Length") > pl$col("Sepal.Length")$mean())', + "# complete after the query") + for (row in c(3L, 5L)) { + for (receiver in c("dt", "pl")) { + content <- lines + content[[row + 1L]] <- paste0(receiver, "$") + document <- Document$new("file:///polars-conversion.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + point <- list(row = row, col = 3L) + resolved <- member_resolve_cursor(document$uri, workspace, document, point, + member_cursor(document, point)) + info <- paste(conversion, receiver, row) + expect_identical(resolved$value$type, if (receiver == "dt") "polars_data_frame" else "pl", info = info) + expect_false(resolved$budget$exhausted, info = info) + items <- member_completion(document$uri, workspace, document, point, TRUE, 200L) + labels <- vapply(items, `[[`, character(1L), "label") + expected <- if (receiver == "dt") c("filter", "lazy", "select") else c("col", "DataFrame") + expect_true(all(expected %in% labels), info = info) + expect_true(all(vapply(items, function(item) identical(item$data$type, "member"), logical(1L))), info = info) + } + } + } +}) From a253130c1e955e3d9c97fd08873c26756b43434e Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 29 Oct 2026 22:17:06 +0800 Subject: [PATCH 03/12] Cache package metadata across sessions and preserve chained member inference --- NEWS.md | 8 ++ R/document.R | 16 ++- R/member-completion.R | 16 ++- R/member-inference.R | 27 +++-- R/member-metadata.R | 81 +++++++++---- R/namespace.R | 8 ++ R/package-cache.R | 109 ++++++++++++++++++ R/s3-metadata.R | 49 +++++++- R/utils.R | 11 +- R/workspace.R | 8 +- README.md | 12 ++ tests/testthat/test-member-completion.R | 8 +- tests/testthat/test-member-return-dispatch.R | 6 + tests/testthat/test-member-reuse-budget.R | 71 ++++++++++++ tests/testthat/test-package-metadata-cache.R | 108 +++++++++++++++++ .../test-polars-dataframe-completion.R | 29 ++++- 16 files changed, 519 insertions(+), 48 deletions(-) create mode 100644 R/package-cache.R create mode 100644 tests/testthat/test-member-reuse-budget.R create mode 100644 tests/testthat/test-package-metadata-cache.R diff --git a/NEWS.md b/NEWS.md index 5760b083..95513863 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,14 @@ - Preserve member completion for Polars conversions such as `dt <- as_polars_df(iris)` and for `pl$` after calls using the converted frame. Prepare bounded S3 method return summaries with their owning namespace. + Retain namespace ownership through chained methods and nested argument + expressions. Retry timed-out member requests with an adaptive allowance + within a one-second total deadline. + +- Persist package member models, startup datasets, S3 catalogs, documentation + summaries and rendered help in a shared bounded cache. Reuse unchanged models + across saves and server sessions; invalidate changes to package files, + dependencies, registered methods, cache format or server implementation. - Avoid a server crash when completion, hover or signature help is requested inside `function()`, `if`, `for` or `while` while package metadata is loading. diff --git a/R/document.R b/R/document.R index 0047afea..3a140be7 100644 --- a/R/document.R +++ b/R/document.R @@ -22,6 +22,7 @@ Document <- R6::R6Class( requested_packages = NULL, member_refresh = FALSE, member_receivers = NULL, + member_budgets = NULL, s3_calls = NULL, s3_identity = NULL, member_revision = NULL, @@ -37,6 +38,7 @@ Document <- R6::R6Class( self$version <- version self$is_rmarkdown <- is_rmarkdown(uri, language) self$member_receivers <- ByteLruCache$new(4 * 1024^2, max_entries = 32L) + self$member_budgets <- ByteLruCache$new(16384L, max_entries = 32L) self$s3_calls <- ByteLruCache$new(1 * 1024^2, max_entries = 32L) self$set_content(version, content) self$loaded_packages <- character() @@ -1099,6 +1101,16 @@ resolve_callback <- function(self, uri, version, packages) { resolve_member_task <- function(self, uri, document, packages, namespace_packages) { workspace <- self$get_workspace(uri) + metadata <- workspace$member_metadata + known <- list() + if (!is.null(metadata)) { + for (package in metadata$keys()) { + catalog <- if (is.function(metadata$catalog)) metadata$catalog(package) else metadata$get(package) + if (!isTRUE(catalog$dataset_only) && is.null(catalog$error) && !is.null(catalog$identity)) { + known[package] <- list(catalog$identity) + } + } + } requested <- document$requested_packages version <- document$version current <- function() { @@ -1109,7 +1121,7 @@ resolve_member_task <- function(self, uri, document, packages, namespace_package create_task( target = package_call(member_resolve_packages), args = list(pkgs = packages, lib_paths = .libPaths(), namespace_packages = namespace_packages, - prepare = TRUE, prepare_s3 = FALSE), + prepare = TRUE, prepare_s3 = FALSE, known_members = known, cache_dir = package_metadata_cache_root()), callback = function(result) { if (current()) resolve_callback(self, uri, version, result) }, @@ -1139,7 +1151,7 @@ resolve_task <- function(self, uri, document, packages, delay = 0, namespace_pac target = package_call(member_resolve_packages), args = list(pkgs = packages, lib_paths = .libPaths(), namespace_packages = namespace_packages, prepare = prepare_members && !split_members, - prepare_s3 = isTRUE(lsp_settings$get("s3_dispatch"))), + prepare_s3 = isTRUE(lsp_settings$get("s3_dispatch")), cache_dir = package_metadata_cache_root()), callback = function(result) resolve_callback(self, uri, version, result), error = function(e) { on.exit(s3_queue_ready(self, uri), add = TRUE) diff --git a/R/member-completion.R b/R/member-completion.R index 8a58bda9..abdead25 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -844,7 +844,7 @@ member_recover_scope <- function(document, point, cursor, data) { member_recover(document, point, cursor, data) } -member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL) { +member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL, retry_deadline = NULL) { if (!identical(document$version, document$parse_data$version) && !is.null(document$parse_data$version)) { return(NULL) @@ -864,8 +864,15 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name revision = revision) if (!identical(document$member_revision, identity)) { cache$clear() + document$member_budgets$clear() document$member_revision <- identity } + budget_key <- paste(point$row, cursor$operator_row, cursor$operator, cursor$accessor, sep = ":") + if (!is.null(budget$time_limit) && budget$time_limit < 1) { + ceiling <- if (is.null(retry_deadline)) proc.time()[[3L]] + 1 else retry_deadline + budget$time_limit <- document$member_budgets$get(budget_key, budget$time_limit) + budget$deadline <- min(proc.time()[[3L]] + budget$time_limit, ceiling) + } # The receiver does not depend on the member prefix or the call arguments # after it. Edits and accepted parses clear this document-local cache. key <- paste(point$row, cursor$start, cursor$end, cursor$operator_row, @@ -911,6 +918,13 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name value$function_key <- key[[1L]] } } + if (isTRUE(budget$timed_out) && budget$time_limit < 1 && is.null(retry_deadline) && + proc.time()[[3L]] < ceiling) { + # Retry a timed-out receiver once using reusable package summaries. + # Learn a larger allowance for this cursor, capped at one second total. + document$member_budgets$set(budget_key, min(1, budget$time_limit * 2)) + return(member_resolve_cursor(uri, workspace, document, point, cursor, name, retry_deadline = ceiling)) + } list(value = value, index = index, bindings = bindings, budget = budget) } diff --git a/R/member-inference.R b/R/member-inference.R index 55d41c73..0c1eb652 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -212,7 +212,7 @@ member_join <- function(a, b) { ) if (!identical(a$classes, b$classes) && (length(a$classes) || length(b$classes))) value$reason <- "ambiguous_class" if (!identical(a$member_package, b$member_package) && - (!is.null(a$member_package) || !is.null(b$member_package)) && !is.null(fields)) { + !is.null(a$member_package) && !is.null(b$member_package) && !is.null(fields)) { # Object names are local to each namespace; a joined receiver can only # retain its common structural fields, not either package's registry. value$type <- if (all(c(a$type, b$type) %in% c("list", "pairlist")) || @@ -450,11 +450,15 @@ member_access <- function(lhs, name, index, bindings) { } property <- member_lookup(member_lookup(index$properties, lhs$type), name) if (!is.null(property)) { - return(if (is.character(property)) member_value(type = property) else property) + value <- if (is.character(property)) member_value(type = property) else property + if (is.null(value$member_package) && length(value$type) == 1L && value$type %in% names(index$members)) { + value$member_package <- index$package + } + return(value) } raw <- member_lookup(member_lookup(index$raw_fields, lhs$type), name) if (!is.null(raw)) { - return(member_value(type = raw)) + return(member_value(type = raw, member_package = index$package)) } members <- member_lookup(index$members, lhs$type) if (name %in% names(members) && !is.na(members[[name]])) { @@ -495,6 +499,7 @@ member_infer <- function( } if (isTRUE(budget$exhausted) || depth > 64L || budget$remaining < 0L || timed_out) { budget$exhausted <- TRUE + if (timed_out) budget$timed_out <- TRUE return(member_value(reason = "budget")) } infer <- function(x, env = bindings, ctx = context) { @@ -514,10 +519,13 @@ member_infer <- function( } package_env <- if (!is.null(index$package_roots)) index$package_roots else index$roots join_env <- function(a, b) { + if (identical(a, b)) return(a) keys <- union(names(a), names(b)) - stats::setNames(lapply(keys, function(key) { - x <- member_lookup(a, key) - y <- member_lookup(b, key) + xs <- a[match(keys, names(a))] + ys <- b[match(keys, names(b))] + stats::setNames(lapply(seq_along(keys), function(i) { + x <- xs[[i]] + y <- ys[[i]] if (identical(x, y)) return(x) if (!is.list(x) || !is.list(y)) unknown else member_join(x, y) }), keys) @@ -785,7 +793,7 @@ member_infer <- function( } shape <- member_lookup(index$constructor_types, key) if (!is.null(shape)) { - return(member_value(type = shape)) + return(member_value(type = shape, member_package = index$package)) } if (!member_head(fn, "function")) { return(unknown) @@ -861,7 +869,7 @@ member_infer <- function( recipe <- ctor$fields[[name]] factory <- member_lookup(index$members[[ctor$type]], name) if (!is.null(factory) && !is.na(factory) && factory %in% index$native_factories) { - value <- member_value(function_key = factory) + value <- member_value(function_key = factory, metadata = index$package) } else if (isTRUE(recipe$active)) { body <- recipe$expr if (member_head(body, "function")) body <- body[[3L]] @@ -875,7 +883,8 @@ member_infer <- function( } fields[name] <- list(value) } - result <- member_value(type = ctor$type, classes = ctor$classes, fields = fields) + result <- member_value(type = ctor$type, classes = ctor$classes, fields = fields, + member_package = index$package) } else { body <- fn[[3L]] ctx <- list(key = key, actuals = actuals, formals = names(fn[[2L]]), dispatch = dispatch, diff --git a/R/member-metadata.R b/R/member-metadata.R index baed9e83..7577f544 100644 --- a/R/member-metadata.R +++ b/R/member-metadata.R @@ -66,10 +66,7 @@ member_subset_registry <- function(ns, package) { list(methods = methods, complete = TRUE) } -member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes = list(), - lookup_scope = parent.frame()) { - seen <- list() - remaining <- max_bindings +member_snapshot_dollar_context <- function(lookup_scope) { method_scopes <- list() scope <- lookup_scope while (is.environment(scope) && !identical(scope, emptyenv())) { @@ -86,6 +83,16 @@ member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes env = registered, names = ls(registered, all.names = TRUE) ) } + list(scopes = method_scopes, registered = registered) +} + +member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes = list(), + lookup_scope = parent.frame(), dollar_context = NULL) { + seen <- list() + remaining <- max_bindings + if (is.null(dollar_context)) dollar_context <- member_snapshot_dollar_context(lookup_scope) + method_scopes <- dollar_context$scopes + registered <- dollar_context$registered dollar_methods <- new.env(parent = emptyenv()) default_dollar <- function(current) { if (isS4(current) || is.null(registered)) return(FALSE) @@ -555,6 +562,7 @@ member_namespace_input <- function( # function IDs for documentation; anonymous registry closures get path IDs. function_names <- names(functions) remaining_bindings <- 50000L + dollar_context <- member_snapshot_dollar_context(ns) for (name in names(values)) { value <- values[[name]] if (is.environment(value) && (isNamespace(value) || identical(value, ns) || identical(value, globalenv()) || @@ -577,7 +585,8 @@ member_namespace_input <- function( } remaining_bindings <- remaining_bindings - size snapshots[name] <- list(member_snapshot(value, - max_bindings = remaining_bindings + size, s7_modes = s7_modes, lookup_scope = ns)) + max_bindings = remaining_bindings + size, s7_modes = s7_modes, lookup_scope = ns, + dollar_context = dollar_context)) definitions[name] <- list(if (is.environment(value)) quote(new.env(parent = emptyenv())) else quote(list())) methods <- character() fields <- if (snapshots[[name]]$kind %in% c("environment", "r6_instance")) { @@ -630,7 +639,8 @@ member_namespace_input <- function( tryCatch({ record <- member_binding(lazydata, name, materialize = TRUE) snapshot <- if (identical(record[[1L]], "value")) { - member_snapshot(record[[2L]], max_bindings = 5000L, s7_modes = s7_modes, lookup_scope = ns) + member_snapshot(record[[2L]], max_bindings = 5000L, s7_modes = s7_modes, lookup_scope = ns, + dollar_context = dollar_context) } else { list(kind = "unknown", reason = "deferred_dataset") } @@ -685,9 +695,15 @@ member_index_thaw <- function(snapshot) { index } -member_prepare_package <- function(package, lib_paths = .libPaths()) { +member_prepare_package <- function(package, lib_paths = .libPaths(), context = NULL) { .libPaths(lib_paths) ns <- asNamespace(package) + identity <- package_metadata_identity(package, lib_paths, context) + cache_path <- package_metadata_cache_path("members", identity) + cached <- package_metadata_cache_read(cache_path, identity, function(value) { + identical(value$identity, identity) && !is.null(member_index_thaw(value)) + }) + if (!is.null(cached)) return(cached) prepare <- function(input, preparation_error = NULL) { index <- member_package_index(input) for (name in names(index$package_roots)) { @@ -706,13 +722,10 @@ member_prepare_package <- function(package, lib_paths = .libPaths()) { index$namespace_attempted <- TRUE index$preparation_error <- preparation_error } - index$identity <- list( - package = package, path = find.package(package), - version = as.character(utils::packageVersion(package)), r = as.character(getRversion()) - ) + index$identity <- identity member_index_freeze(index) } - tryCatch(prepare(member_namespace_input(ns)), error = function(e) { + snapshot <- tryCatch(prepare(member_namespace_input(ns)), error = function(e) { message <- conditionMessage(e) lazydata <- member_namespace_lazydata(ns) if (!grepl("^Namespace exceeds .* budget$", message) || !is.environment(lazydata) || @@ -720,35 +733,61 @@ member_prepare_package <- function(package, lib_paths = .libPaths()) { # A large normal namespace must not hide its lightweight public data. prepare(member_namespace_input(ns, lazydata = lazydata, lazydata_only = TRUE), message) }) + package_metadata_cache_write(cache_path, identity, snapshot) + snapshot } -member_prepare_startup_data <- function(packages, lib_paths = .libPaths()) { +member_prepare_startup_data <- function(packages, lib_paths = .libPaths(), cache_dir = package_metadata_cache_root()) { .libPaths(lib_paths) + previous <- options(languageserver.package_cache_dir = cache_dir) + on.exit(options(previous), add = TRUE) snapshots <- list() for (package in unique(packages)) { snapshot <- tryCatch({ ns <- asNamespace(package) lazydata <- member_namespace_lazydata(ns) if (!is.environment(lazydata) || !length(ls(lazydata, all.names = TRUE))) next - input <- member_namespace_input(ns, package, lazydata = lazydata, lazydata_only = TRUE) - index <- member_package_index(input) - index$dataset_only <- TRUE - index$identity <- list(package = package, path = find.package(package), - version = as.character(utils::packageVersion(package)), r = as.character(getRversion())) - member_index_freeze(index) + identity <- package_metadata_identity(package, lib_paths) + path <- package_metadata_cache_path("startup-members", identity) + cached <- package_metadata_cache_read(path, identity, function(value) { + identical(value$identity, identity) && isTRUE(value$dataset_only) && !is.null(member_index_thaw(value)) + }) + if (!is.null(cached)) { + cached + } else { + input <- member_namespace_input(ns, package, lazydata = lazydata, lazydata_only = TRUE) + index <- member_package_index(input) + index$dataset_only <- TRUE + index$identity <- identity + value <- member_index_freeze(index) + package_metadata_cache_write(path, identity, value) + value + } }, error = function(e) NULL) if (!is.null(snapshot)) snapshots[package] <- list(snapshot) } snapshots } -member_resolve_packages <- function(pkgs, lib_paths, prepare = TRUE, namespace_packages = character(), prepare_s3 = TRUE) { +member_resolve_packages <- function(pkgs, lib_paths, prepare = TRUE, namespace_packages = character(), prepare_s3 = TRUE, + known_members = list(), cache_dir = package_metadata_cache_root()) { .libPaths(lib_paths) + previous <- options(languageserver.package_cache_dir = cache_dir) + on.exit(options(previous), add = TRUE) packages <- resolve_attached_packages(pkgs) snapshots <- list() if (isTRUE(prepare)) { + context_packages <- sort(unique(c(packages, namespace_packages))) + # All requested namespaces must register their methods before any + # cached model is compared or a new dispatch snapshot is prepared. + for (package in namespace_packages) tryCatch(asNamespace(package), error = function(e) NULL) + member_s7_capabilities() + if ("S7" %in% loadedNamespaces()) context_packages <- sort(union(context_packages, "S7")) + context <- package_metadata_context(context_packages) for (package in unique(c(setdiff(packages, startup_packages), namespace_packages))) { - snapshots[package] <- list(tryCatch(member_prepare_package(package, lib_paths), + identity <- tryCatch(package_metadata_identity(package, lib_paths, context), error = function(e) NULL) + if (!is.null(identity) && identical(known_members[[package]], identity)) next + snapshots[package] <- list(tryCatch(member_prepare_package(package, lib_paths, context), error = function(e) { list( schema = 1L, roots = list(), namespace_roots = list(), diff --git a/R/namespace.R b/R/namespace.R index 11edd42c..38e00fdd 100644 --- a/R/namespace.R +++ b/R/namespace.R @@ -157,6 +157,13 @@ PackageNamespace <- R6::R6Class("PackageNamespace", if (private$documentation$has(topic)) { return(private$documentation$get(topic)) } + identity <- tryCatch(package_metadata_identity(pkgname), error = function(e) NULL) + cache_path <- if (!is.null(identity)) package_metadata_cache_path("documentation", identity, topic) + cached <- package_metadata_cache_read(cache_path, identity) + if (!is.null(cached)) { + private$documentation$set(topic, cached) + return(cached) + } hfile <- utils::help((topic), (pkgname)) if (length(hfile) > 0) { @@ -189,6 +196,7 @@ PackageNamespace <- R6::R6Class("PackageNamespace", value <- list() } private$documentation$set(topic, value) + package_metadata_cache_write(cache_path, identity, value) value }, diff --git a/R/package-cache.R b/R/package-cache.R new file mode 100644 index 00000000..5c87ee56 --- /dev/null +++ b/R/package-cache.R @@ -0,0 +1,109 @@ +# Shared storage for immutable package metadata. Providers choose their type, +# identity/context, and validator; live functions and document state stay local. +package_metadata_identity <- function(package, lib_paths = .libPaths(), context = NULL) { + path <- find.package(package, lib.loc = lib_paths) + files <- c(file.path(path, c("DESCRIPTION", "NAMESPACE")), + unlist(lapply(c("R", "data", "help"), function(directory) { + list.files(file.path(path, directory), pattern = "\\.(rdb|rdx|rds)$", full.names = TRUE) + }), use.names = FALSE), list.files(file.path(path, "libs"), full.names = TRUE, recursive = TRUE)) + info <- file.info(files) + list(package = package, path = path, + version = as.character(utils::packageVersion(package, lib.loc = lib_paths)), r = as.character(getRversion()), + files = digest::digest(list(files, info$size, as.numeric(info$mtime)), algo = "xxhash64"), context = context) +} + +package_metadata_cache_root <- function() { + value <- getOption("languageserver.package_cache_dir", + Sys.getenv("R_LANGSVR_PACKAGE_CACHE_DIR", tools::R_user_dir("languageserver", "cache"))) + if (!is.character(value) || length(value) != 1L || is.na(value) || !nzchar(value)) return(FALSE) + value +} + +package_metadata_cache_directory <- function() { + value <- package_metadata_cache_root() + if (identical(value, FALSE)) NULL else file.path(value, "package-metadata") +} + +package_metadata_cache_server <- local({ + identity <- NULL + function() { + if (!is.null(identity)) return(identity) + ns <- asNamespace("languageserver") + values <- list() + for (name in ls(ns, all.names = TRUE)) { + if (identical(name, ".packageName")) next + record <- member_binding(ns, name, materialize = TRUE) + value <- record[[2L]] + if (typeof(value) == "closure") { + values[name] <- list(deparse1(member_function_syntax(value))) + } else if (is.environment(value) && "R6ClassGenerator" %in% attr(value, "class", exact = TRUE)) { + methods <- list(public = value$public_methods, private = value$private_methods, active = value$active) + values[name] <- list(lapply(methods, function(section) { + lapply(section, function(method) { + if (typeof(method) == "closure") deparse1(member_function_syntax(method)) + }) + })) + } else if (!is.object(value) && is.atomic(value) && length(value) <= 10000L) { + values[name] <- list(value) + } else if (is.list(value) && all(vapply(value, is.atomic, logical(1L)))) { + values[name] <- list(value) + } + } + dll <- getLoadedDLLs()[["languageserver"]][["path"]] + identity <<- list(version = getNamespaceInfo(ns, "spec")[["version"]], + implementation = digest::digest(values, algo = "xxhash64"), native = unname(tools::md5sum(dll))) + identity + } +}) + +package_metadata_cache_path <- function(type, identity, key = NULL) { + directory <- package_metadata_cache_directory() + if (is.null(directory)) return(NULL) + hash <- digest::digest(list(format = 1L, type = type, key = key, identity = identity, + server = package_metadata_cache_server()), algo = "xxhash64") + file.path(directory, paste0(identity$package, "-", type, "-", hash, ".rds")) +} + +package_metadata_cache_read <- function(path, identity, validate = is.list) { + if (is.null(path) || !file.exists(path)) return(NULL) + tryCatch({ + record <- readRDS(path) + if (!identical(record$format, 1L) || !identical(record$server, package_metadata_cache_server()) || + !identical(record$identity, identity) || + !isTRUE(validate(record$value))) return(NULL) + suppressWarnings(Sys.setFileTime(path, Sys.time())) + record$value + }, error = function(e) NULL) +} + +package_metadata_cache_write <- function(path, identity, value) { + if (is.null(path)) return(invisible(NULL)) + temporary <- NULL + on.exit(if (!is.null(temporary)) unlink(temporary), add = TRUE) + tryCatch(suppressWarnings({ + directory <- dirname(path) + dir.create(directory, recursive = TRUE, showWarnings = FALSE) + temporary <- tempfile("metadata-", tmpdir = directory) + saveRDS(list(format = 1L, server = package_metadata_cache_server(), identity = identity, value = value), temporary) + if (!file.rename(temporary, path)) { + # Windows cannot replace an existing cache file with file.rename. + # A racing reader can safely miss the cache and prepare its model. + unlink(path) + if (!file.rename(temporary, path)) return(invisible(NULL)) + } + files <- list.files(directory, pattern = "\\.rds$", full.names = TRUE) + info <- file.info(files) + order <- order(info$mtime, decreasing = TRUE, na.last = TRUE) + sizes <- info$size[order] + sizes[is.na(sizes)] <- 0 + expired <- order[seq_along(order) > 512L | cumsum(sizes) > 256 * 1024^2] + if (length(expired)) unlink(files[expired]) + }), error = function(e) NULL) + invisible(NULL) +} + +package_metadata_context <- function(packages) { + list(packages = lapply(packages, function(package) { + tryCatch(package_metadata_identity(package), error = function(e) list(package = package, error = conditionMessage(e))) + }), bindings = s3_metadata_context(packages)) +} diff --git a/R/s3-metadata.R b/R/s3-metadata.R index c96a9829..0d7c7e93 100644 --- a/R/s3-metadata.R +++ b/R/s3-metadata.R @@ -259,10 +259,7 @@ s3_prepare_namespace <- function(package) { result <- list( schema = 1L, package = package, functions = functions, callables = callables, objects = objects, methods = methods, dependencies = dependencies, - identity = list( - path = find.package(package), version = as.character(utils::packageVersion(package)), - r = as.character(getRversion()) - ) + identity = package_metadata_identity(package) ) size <- as.numeric(utils::object.size(result)) if (size > 8 * 1024^2) stop(sprintf("Namespace %s exceeds S3 metadata budget (%d bytes)", package, size)) @@ -270,7 +267,9 @@ s3_prepare_namespace <- function(package) { result } -s3_prepare_packages <- function(packages) { +s3_prepare_packages <- function(packages, cache_dir = package_metadata_cache_root()) { + previous <- options(languageserver.package_cache_dir = cache_dir) + on.exit(options(previous), add = TRUE) namespaces <- list() pending <- unique(c(startup_packages, packages)) # Load the requested namespaces before snapshotting any owning registry. @@ -286,8 +285,25 @@ s3_prepare_packages <- function(packages) { pending <- unique(c(pending, setdiff(namespaces[[package]]$dependencies, names(namespaces)))) } result <- list() + context <- package_metadata_context(names(namespaces)) for (package in names(namespaces)) { - result[[package]] <- tryCatch(s3_prepare_namespace(package), error = function(e) { + result[[package]] <- tryCatch({ + identity <- package_metadata_identity(package, context = context) + path <- package_metadata_cache_path("s3", identity) + cached <- package_metadata_cache_read(path, identity, function(value) { + identical(value$schema, 1L) && identical(value$identity, identity) + }) + if (!is.null(cached)) { + cached + } else { + value <- s3_prepare_namespace(package) + value$identity <- identity + value$generation <- NULL + value$generation <- digest::digest(value, algo = "xxhash64") + package_metadata_cache_write(path, identity, value) + value + } + }, error = function(e) { list( schema = 1L, package = package, functions = list(), objects = list(), methods = list(), dependencies = character(), generation = "", error = conditionMessage(e) @@ -297,6 +313,27 @@ s3_prepare_packages <- function(packages) { result } +# Registries and exported functions may be replaced by load hooks or tracing +# without changing package files. Include their current inert syntax in S3 keys. +s3_metadata_context <- function(packages) { + records <- lapply(packages, function(package) tryCatch({ + ns <- asNamespace(package) + describe <- function(scope, names) stats::setNames(lapply(names, function(name) { + record <- member_binding(scope, name, materialize = TRUE) + value <- record[[2L]] + owner <- if (typeof(value) == "closure" && isNamespace(environment(value))) { + unname(getNamespaceName(environment(value))) + } + list(kind = record[[1L]], owner = owner, syntax = if (typeof(value) == "closure") member_function_syntax(value), + primitive = if (is.primitive(value)) name) + }), names) + table <- member_binding(ns, ".__S3MethodsTable__.")[[2L]] + list(exports = describe(ns, getNamespaceExports(ns)), + methods = if (is.environment(table) && length(table)) describe(table, ls(table, all.names = TRUE))) + }, error = function(e) list(error = conditionMessage(e)))) + digest::digest(records, algo = "xxhash64") +} + s3_namespace_binding <- function(ns, name) { # Re-exports can resolve through the imports environment into base. # Stop at an existing binding so active bindings never expose a fallback. diff --git a/R/utils.R b/R/utils.R index 4e995f74..571cc75f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -600,8 +600,13 @@ get_help <- function(hfile, format = c("html", "text")) { return(NULL) } - rd <- get_help_rd(hfile) pkgname <- basename(dirname(dirname(paths[[1]]))) + identity <- tryCatch(package_metadata_identity(pkgname), error = function(e) NULL) + cache_path <- if (!is.null(identity)) package_metadata_cache_path(paste0("help-", format), identity, + list(paths, locale = Sys.getlocale("LC_MESSAGES"))) + cached <- package_metadata_cache_read(cache_path, identity, is.character) + if (!is.null(cached)) return(cached) + rd <- get_help_rd(hfile) if (format == "html") { result <- paste0(utils::capture.output( @@ -616,7 +621,9 @@ get_help <- function(hfile, format = c("html", "text")) { stop("Invalid format") } - enc2utf8(result) + result <- enc2utf8(result) + package_metadata_cache_write(cache_path, identity, result) + result } convert_doc_to_markdown <- function(doc) { diff --git a/R/workspace.R b/R/workspace.R index 7915b4b6..5e50beb2 100644 --- a/R/workspace.R +++ b/R/workspace.R @@ -182,7 +182,7 @@ MemberMetadataCache <- R6::R6Class( snapshot$cache <- NULL # Selection, imports and dispatch need only this compact catalog. # Keep it in the snapshot budget without decoding function bodies. - fields <- c("package", "generation", "roots", "exports", "namespace_roots", "classes", "class_scope", "symbol_scope", + fields <- c("package", "identity", "generation", "roots", "exports", "namespace_roots", "classes", "class_scope", "symbol_scope", "s4_classes", "s4_dependencies", "s7_dependencies", "s7_capabilities", "dataset_only", "namespace_attempted", "subset_registry", "subset_registry_complete") entry <- list( @@ -1127,7 +1127,8 @@ workspace_startup_s3 <- local({ function() { if (!is.null(cached)) return(cached) packages <- workspace_startup_packages() - cached <<- tryCatch(callr::r(package_call(s3_prepare_packages), args = list(packages), + cached <<- tryCatch(callr::r(package_call(s3_prepare_packages), + args = list(packages = packages, cache_dir = package_metadata_cache_root()), system_profile = FALSE, user_profile = FALSE, timeout = if (identical(Sys.getenv("R_COVR"), "true")) 60 else 8), error = function(e) { @@ -1145,7 +1146,8 @@ workspace_startup_members <- local({ cached <- NULL previous <- NULL function() { - requested <- list(packages = workspace_startup_packages(), lib_paths = .libPaths()) + requested <- list(packages = workspace_startup_packages(), lib_paths = .libPaths(), + cache_dir = package_metadata_cache_root()) if (!is.null(cached) && identical(requested, previous)) return(cached) if (!length(requested$packages)) return(list()) result <- tryCatch(callr::r(package_call(member_prepare_startup_data), args = requested, diff --git a/README.md b/README.md index 9ad8f064..5f42d321 100644 --- a/README.md +++ b/README.md @@ -298,6 +298,18 @@ options(languageserver.snippet_support = FALSE) will turn off snippet support globally. LSP configuration settings are always overriden by `options()`. +Package member models, startup datasets, S3 catalogs, documentation summaries and +rendered help share a persistent cache under `tools::R_user_dir("languageserver", "cache")`. +It keeps up to 512 entries and 256 MiB, removing older entries as needed. Package +file, dependency, registry, R version and server implementation changes invalidate +cached results; incompatible or corrupt entries are rebuilt. Document-dependent +inference remains local to the current document and its metadata revision. +Set `options(languageserver.package_cache_dir = "/path/to/cache")` or the +`R_LANGSVR_PACKAGE_CACHE_DIR` environment variable to choose another cache root; +set `options(languageserver.package_cache_dir = FALSE)` to disable disk caching. +These options are also passed to metadata workers. Timed-out member requests +retry once with a larger allowance, capped at one second for the whole request. + Automatic indexing recognizes a package by its `DESCRIPTION` with a `Package` field and its `R/` directory. Package indexing runs in the background and prioritizes package sources. A workspace containing standalone scripts starts diff --git a/tests/testthat/test-member-completion.R b/tests/testthat/test-member-completion.R index ca8f55aa..0312190b 100644 --- a/tests/testthat/test-member-completion.R +++ b/tests/testthat/test-member-completion.R @@ -20,7 +20,7 @@ member_items <- function(code, snapshots = list(), point = NULL, language = "r", member_labels <- function(...) vapply(member_items(...), `[[`, character(1L), "label") -test_that("Member inference allows test overhead without changing the production limit", { +test_that("The initial inference allowance distinguishes production from test overhead", { fixture <- member_fixture(paste0("x <- list(alpha = list(", paste(rep("1", 256L), collapse = ","), "))\nx$")) calls <- 0L clock <- function() { @@ -36,8 +36,10 @@ test_that("Member inference allows test overhead without changing the production testthat::local_mocked_bindings(member_request_budget = budget, .package = "languageserver") resolve <- function() { calls <<- 0L - member_resolve_cursor(fixture$document$uri, fixture$workspace, fixture$document, - fixture$point, member_cursor(fixture$document, fixture$point)) + budget <- member_request_budget() + expr <- fixture$document$parse_data$member_data$bindings$x[[1L]]$expr + value <- member_infer(expr, member_generic_index(""), budget = budget) + list(value = value, budget = budget) } withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) expect_true(resolve()$budget$exhausted) diff --git a/tests/testthat/test-member-return-dispatch.R b/tests/testthat/test-member-return-dispatch.R index 9ff8c071..68209a6f 100644 --- a/tests/testthat/test-member-return-dispatch.R +++ b/tests/testthat/test-member-return-dispatch.R @@ -41,4 +41,10 @@ test_that("Prepared S3 method returns retain namespace ownership and argument ma items <- member_completion(document$uri, list(member_metadata = metadata), document, list(row = 2L, col = nchar(content[[3L]])), FALSE, 200L) expect_identical(vapply(items, `[[`, character(1L), "label"), "raw") + content[[3L]] <- "converted$raw$step()$" + document <- Document$new("file:///conversion-chain.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + items <- member_completion(document$uri, list(member_metadata = metadata), document, + list(row = 2L, col = nchar(content[[3L]])), FALSE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), "step") }) diff --git a/tests/testthat/test-member-reuse-budget.R b/tests/testthat/test-member-reuse-budget.R new file mode 100644 index 00000000..69e8b1a5 --- /dev/null +++ b/tests/testthat/test-member-reuse-budget.R @@ -0,0 +1,71 @@ +test_that("Package preparation reuses unchanged models and refreshes changed dependencies", { + revisions <- c(cachefixture = 1L, dependencyfixture = 1L) + prepared <- character() + identity <- function(package, ...) list(package = package, revision = revisions[[package]]) + testthat::local_mocked_bindings( + resolve_attached_packages = function(...) names(revisions), + package_metadata_identity = identity, + member_prepare_package = function(package, ...) { + prepared <<- c(prepared, package) + list(identity = identity(package)) + }, .package = "languageserver") + known <- stats::setNames(lapply(names(revisions), identity), names(revisions)) + result <- member_resolve_packages("cachefixture", .libPaths(), prepare_s3 = FALSE, known_members = known) + expect_length(result$members, 0L) + expect_length(prepared, 0L) + expect_identical(result$packages, names(revisions)) + revisions[["dependencyfixture"]] <- 2L + result <- member_resolve_packages("cachefixture", .libPaths(), prepare_s3 = FALSE, known_members = known) + expect_identical(names(result$members), "dependencyfixture") + expect_identical(prepared, "dependencyfixture") + expect_identical(result$members$dependencyfixture$identity$revision, 2L) +}) + +test_that("Member catalogs retain identities for reuse by package workers", { + index <- member_generic_index("") + index$package <- "cachefixture" + index$identity <- list(package = "cachefixture", revision = 1L) + metadata <- MemberMetadataCache$new(1024^2) + metadata$set("cachefixture", member_index_freeze(index)) + expect_identical(metadata$catalog("cachefixture")$identity, index$identity) +}) + +test_that("Timed-out member receivers retry with more time and cache successful results", { + metadata <- MemberMetadataCache$new(1024^2) + workspace <- list(member_metadata = metadata) + content <- c("x <- list(alpha = 1)", "x$") + document <- Document$new("file:///adaptive-members.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + point <- list(row = 1L, col = 2L) + limits <- numeric() + budget_factory <- member_request_budget + infer <- member_cursor_value + testthat::local_mocked_bindings( + member_request_budget = function() { + budget <- budget_factory() + budget$time_limit <- 0.25 + budget + }, + member_cursor_value = function(parsed, sentinel, index, bindings, budget, ...) { + limits <<- c(limits, budget$time_limit) + if (budget$time_limit < 0.5) { + budget$exhausted <- budget$timed_out <- TRUE + return(member_value(reason = "budget")) + } + infer(parsed, sentinel, index, bindings, budget, ...) + }, .package = "languageserver") + resolve <- function() member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) + expect_identical(names(resolve()$value$fields), "alpha") + expect_identical(limits, c(0.25, 0.5)) + expect_identical(names(resolve()$value$fields), "alpha") + expect_length(limits, 2L) + content[[1L]] <- "x <- list(beta = 1)" + document$set_content(2L, content) + document$parse_data <- parse_document(document$uri, content) + expect_identical(names(resolve()$value$fields), "beta") + expect_identical(tail(limits, 1L), 0.5) + index <- member_generic_index("") + metadata$set("changed", member_index_freeze(index)) + expect_identical(names(resolve()$value$fields), "beta") + expect_identical(tail(limits, 2L), c(0.25, 0.5)) +}) diff --git a/tests/testthat/test-package-metadata-cache.R b/tests/testthat/test-package-metadata-cache.R new file mode 100644 index 00000000..4e2a1037 --- /dev/null +++ b/tests/testthat/test-package-metadata-cache.R @@ -0,0 +1,108 @@ +test_that("Persistent package models survive reads and recover from corrupt cache files", { + directory <- withr::local_tempdir() + withr::local_options(languageserver.package_cache_dir = directory) + package_metadata_cache_server() + prepared <- 0L + prepare_input <- member_namespace_input + testthat::local_mocked_bindings(member_namespace_input = function(...) { + prepared <<- prepared + 1L + prepare_input(...) + }, .package = "languageserver") + first <- member_prepare_package("collections") + expect_identical(prepared, 1L) + second <- member_prepare_package("collections") + expect_identical(prepared, 1L) + expect_identical(second, first) + path <- package_metadata_cache_path("members", first$identity) + expect_true(file.exists(path)) + cross_session <- file.path(directory, "cross-session.rds") + callr::r(function(path, identity, value) { + languageserver:::package_metadata_cache_write(path, identity, value) + }, args = list(cross_session, first$identity, first), libpath = .libPaths(), + system_profile = FALSE, user_profile = FALSE) + restored <- callr::r(function(path, identity) { + languageserver:::package_metadata_cache_read(path, identity) + }, args = list(cross_session, first$identity), libpath = .libPaths(), system_profile = FALSE, user_profile = FALSE) + expect_identical(restored, first) + writeLines("corrupt cache", path) + expect_null(package_metadata_cache_read(path, first$identity)) + third <- member_prepare_package("collections") + expect_identical(prepared, 2L) + expect_identical(third$identity, first$identity) + expect_identical(package_metadata_cache_read(path, first$identity), third) + changed <- member_prepare_package("collections", context = "changed_namespace_context") + expect_identical(prepared, 3L) + expect_false(identical(changed$identity, first$identity)) + expect_null(package_metadata_cache_read(path, changed$identity)) +}) + +test_that("Persistent caching can be disabled without affecting package preparation", { + withr::local_options(languageserver.package_cache_dir = FALSE) + expect_null(package_metadata_cache_directory()) + expect_null(package_metadata_cache_path("members", list(package = "fixture"))) + expect_null(package_metadata_cache_read(NULL, list())) + expect_silent(package_metadata_cache_write(NULL, list(), list())) +}) + +test_that("Cache types, format revisions and server versions remain isolated", { + withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) + identity <- list(package = "fixture", revision = 1L) + paths <- vapply(c("members", "s3", "documentation"), package_metadata_cache_path, character(1L), identity = identity) + expect_length(unique(paths), 3L) + path <- paths[[1L]] + package_metadata_cache_write(path, identity, list(value = "valid")) + expect_identical(package_metadata_cache_read(path, identity), list(value = "valid")) + expect_null(package_metadata_cache_read(path, identity, is.character)) + record <- readRDS(path) + record$format <- 999L + saveRDS(record, path) + expect_null(package_metadata_cache_read(path, identity)) + record$format <- 1L + record$server$version <- "999.0.0" + saveRDS(record, path) + expect_null(package_metadata_cache_read(path, identity)) +}) + +test_that("S3 catalogs reuse cached metadata and detect registry changes", { + withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) + prepared <- character() + prepare <- s3_prepare_namespace + testthat::local_mocked_bindings(s3_prepare_namespace = function(package) { + prepared <<- c(prepared, package) + prepare(package) + }, .package = "languageserver") + first <- s3_prepare_packages("datasets") + expect_true(length(prepared) > 0L) + prepared <- character() + second <- s3_prepare_packages("datasets") + expect_length(prepared, 0L) + expect_identical(second, first) + table <- get(".__S3MethodsTable__.", asNamespace("base")) + method <- "print.persistent_cache_fixture" + withr::defer(rm(list = method, envir = table)) + assign(method, function(x, ...) NULL, table) + changed <- s3_prepare_packages("datasets") + expect_true(length(prepared) > 0L) + expect_false(identical(changed$base$generation, first$base$generation)) + expect_true(paste0("base::", method) %in% names(changed$base$methods)) +}) + +test_that("Documentation and rendered help reuse the shared package cache", { + withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) + parsed <- 0L + parse_help <- get_help_rd + testthat::local_mocked_bindings(get_help_rd = function(...) { + parsed <<- parsed + 1L + parse_help(...) + }, .package = "languageserver") + first <- PackageNamespace$new("base")$get_documentation("sum") + expect_identical(parsed, 1L) + second <- PackageNamespace$new("base")$get_documentation("sum") + expect_identical(second, first) + expect_identical(parsed, 1L) + help <- utils::help("sum", "base") + text <- get_help(help, "text") + expect_identical(parsed, 2L) + expect_identical(get_help(help, "text"), text) + expect_identical(parsed, 2L) +}) diff --git a/tests/testthat/test-polars-dataframe-completion.R b/tests/testthat/test-polars-dataframe-completion.R index d74ee1ff..1ab78c71 100644 --- a/tests/testthat/test-polars-dataframe-completion.R +++ b/tests/testthat/test-polars-dataframe-completion.R @@ -5,9 +5,10 @@ test_that("Polars conversions and later roots complete within a small inference for (package in names(snapshots)) metadata$set(package, snapshots[[package]]) workspace <- list(member_metadata = metadata, startup_packages = "datasets") budget_factory <- member_request_budget + remaining <- 128L testthat::local_mocked_bindings(member_request_budget = function() { budget <- budget_factory() - budget$remaining <- 128L + budget$remaining <- remaining budget }, .package = "languageserver") for (conversion in c("as_polars_df(iris)", "polars::as_polars_df(datasets::iris)", @@ -36,4 +37,30 @@ test_that("Polars conversions and later roots complete within a small inference } } } + remaining <- 512L + for (expression in c( + 'dt$filter(pl$col("a") > pl$col("b")$|)', + 'dt$filter(pl$col("a") > pl$col("b")$me|an())', + "dt$filter()$|", + "dt$filter()$fi|lter()", + "dt$filter(unknown)$|")) { + content <- c("library(polars)", "", "dt <- as_polars_df(iris)", "", + 'dt$filter(pl$col("Sepal.Length") > pl$col("Sepal.Length")$mean())', "", expression) + marker <- regexpr("|", expression, fixed = TRUE)[[1L]] + content[[7L]] <- sub("|", "", expression, fixed = TRUE) + document <- Document$new("file:///polars-nested.R", language = "r", version = 1L, content = content) + data <- parse_document(document$uri, content) + data$version <- 1L + document$update_parse_data(data) + point <- list(row = 6L, col = marker - 1L) + resolved <- member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) + expected_type <- if (grepl('pl$col("b")$', expression, fixed = TRUE)) "polars_expr" else "polars_data_frame" + expect_identical(resolved$value$type, expected_type, info = expression) + expect_identical(resolved$value$member_package, "polars", info = expression) + expect_false(resolved$budget$exhausted, info = expression) + items <- member_completion(document$uri, workspace, document, point, TRUE, 200L) + labels <- vapply(items, `[[`, character(1L), "label") + expect_true(if (expected_type == "polars_expr") "mean" %in% labels else "filter" %in% labels, info = expression) + expect_true(all(vapply(items, function(item) identical(item$data$package, "polars"), logical(1L))), info = expression) + } }) From 0d5673301e3f007ce2e8502f61310c6a6f312b9a Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 29 Oct 2026 23:43:08 +0800 Subject: [PATCH 04/12] Harden metadata cache validation and suggest common members for unknown inputs --- NEWS.md | 8 ++- R/member-completion.R | 35 +++++++++-- R/member-extraction.R | 49 ++++++++++++++-- R/member-inference.R | 20 ++++++- R/member-metadata.R | 31 +++++++--- R/package-cache.R | 58 ++++++++++++++++--- R/s3-metadata.R | 18 ++++-- README.md | 6 +- .../test-member-generic-suggestions.R | 39 +++++++++++++ tests/testthat/test-member-reuse-budget.R | 35 ++++++++++- tests/testthat/test-package-metadata-cache.R | 56 ++++++++++++++++-- .../test-polars-dataframe-completion.R | 9 +++ 12 files changed, 327 insertions(+), 37 deletions(-) create mode 100644 tests/testthat/test-member-generic-suggestions.R diff --git a/NEWS.md b/NEWS.md index 95513863..0a01d748 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,12 +5,16 @@ Prepare bounded S3 method return summaries with their owning namespace. Retain namespace ownership through chained methods and nested argument expressions. Retry timed-out member requests with an adaptive allowance - within a one-second total deadline. + within a one-second total deadline and the original node allowance. Offer + common known method members as possible-receiver suggestions when a + conversion's input class is unresolved, without claiming a definite type. - Persist package member models, startup datasets, S3 catalogs, documentation summaries and rendered help in a shared bounded cache. Reuse unchanged models across saves and server sessions; invalidate changes to package files, - dependencies, registered methods, cache format or server implementation. + loaded namespace values, dependencies, registered methods, cache format or + server implementation. Verify serialized payload checksums before restoring + cached values. - Avoid a server crash when completion, hover or signature help is requested inside `function()`, `if`, `for` or `while` while package metadata is loading. diff --git a/R/member-completion.R b/R/member-completion.R index abdead25..d93488f1 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -844,7 +844,8 @@ member_recover_scope <- function(document, point, cursor, data) { member_recover(document, point, cursor, data) } -member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL, retry_deadline = NULL) { +member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL, retry_deadline = NULL, + remaining_nodes = NULL) { if (!identical(document$version, document$parse_data$version) && !is.null(document$parse_data$version)) { return(NULL) @@ -857,6 +858,7 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name return(NULL) } budget <- member_request_budget() + if (!is.null(remaining_nodes)) budget$remaining <- min(budget$remaining, remaining_nodes) metadata <- workspace$member_metadata cache <- document$member_receivers revision <- if (is.null(metadata)) 0L else if (is.function(metadata$revision)) metadata$revision() else NULL @@ -918,12 +920,13 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name value$function_key <- key[[1L]] } } - if (isTRUE(budget$timed_out) && budget$time_limit < 1 && is.null(retry_deadline) && + if (isTRUE(budget$timed_out) && budget$remaining > 0L && budget$time_limit < 1 && is.null(retry_deadline) && proc.time()[[3L]] < ceiling) { # Retry a timed-out receiver once using reusable package summaries. # Learn a larger allowance for this cursor, capped at one second total. document$member_budgets$set(budget_key, min(1, budget$time_limit * 2)) - return(member_resolve_cursor(uri, workspace, document, point, cursor, name, retry_deadline = ceiling)) + return(member_resolve_cursor(uri, workspace, document, point, cursor, name, retry_deadline = ceiling, + remaining_nodes = budget$remaining)) } list(value = value, index = index, bindings = bindings, budget = budget) } @@ -952,6 +955,21 @@ member_completion <- function(uri, workspace, document, point, snippet_support, return(NULL) } value <- resolved$value + possible <- !length(value$type) && length(value$possible_returns) + common <- NULL + ambiguous <- character() + if (possible) { + sets <- lapply(value$possible_returns, function(candidate) member_members(candidate, resolved$index, resolved$bindings)) + common <- Reduce(intersect, lapply(sets, names)) + if (!length(common)) return(list()) + owners <- vapply(value$possible_returns, function(candidate) { + if (is.null(candidate$member_package)) "" else candidate$member_package + }, character(1L)) + ambiguous <- common[vapply(common, function(name) { + length(unique(owners)) > 1L || !all(vapply(sets, function(set) identical(set[[name]], sets[[1L]][[name]]), logical(1L))) + }, logical(1L))] + value <- value$possible_returns[[1L]] + } index <- member_package_context(resolved$index, value$member_package) bindings <- resolved$bindings budget <- resolved$budget @@ -960,6 +978,7 @@ member_completion <- function(uri, workspace, document, point, snippet_support, return(NULL) } members <- member_members(value, index, bindings, cursor$accessor) + if (possible) members <- members[names(members) %in% common] labels <- as.character(names(members)) if (!length(labels)) { return(list()) @@ -982,8 +1001,13 @@ member_completion <- function(uri, workspace, document, point, snippet_support, if (!is.null(shape)) shape <- member_r6_member_info(shape, value) key <- members[[label]] symbol <- member_symbol_info(label, shape, key, index) + if (label %in% ambiguous) { + symbol$signature <- symbol$function_id <- NULL + symbol$package <- NULL + } is_function <- !is.null(shape$function_expr) || !is.null(shape$result_shape) || !is.null(shape$function_key) || (!is.null(key) && !is.na(key)) + if (label %in% ambiguous && any(vapply(sets, function(set) is.na(set[[label]]), logical(1L)))) is_function <- FALSE inserted <- quote_completion_name(label) snippet <- is_function && call_snippet text <- if (snippet) paste0(escape_completion_snippet(inserted), "($0)") else inserted @@ -992,11 +1016,11 @@ member_completion <- function(uri, workspace, document, point, snippet_support, list( label = label, kind = if (is_function) CompletionItemKind$Method else CompletionItemKind$Field, detail = if (!is.null(signature)) { - signature + if (possible) paste0(signature, " [possible receiver]") else signature } else if (identical(cursor$accessor, "@")) { paste0(label, ": ", paste(value$slot_types[[label]], collapse = " | ")) } else { - "[static member]" + if (possible) "[possible member]" else "[static member]" }, sortText = label, documentation = if (!is.null(symbol$description)) list(kind = "markdown", value = symbol$description), filterText = label, insertTextFormat = if (snippet) InsertTextFormat$Snippet else InsertTextFormat$PlainText, @@ -1008,6 +1032,7 @@ member_completion <- function(uri, workspace, document, point, snippet_support, ) }) if (length(matches) > limit || budget$exhausted) attr(items, "truncated") <- TRUE + if (possible) attr(items, "truncated") <- TRUE items } diff --git a/R/member-extraction.R b/R/member-extraction.R index 66f8ff8c..d5a73dbd 100644 --- a/R/member-extraction.R +++ b/R/member-extraction.R @@ -216,6 +216,7 @@ member_package_index <- function(input) { index$definitions <- input$definitions index$locations <- input$locations index$exports <- input$exports + index$generic_external <- input$generic_external index$subset_registry <- input$subset_registry index$subset_registry_complete <- isTRUE(input$subset_registry_complete) index$registries <- if (!is.null(input$registries)) input$registries else member_source_registries(input) @@ -587,6 +588,7 @@ member_package_index <- function(input) { # which repeatedly infer argument conversion, dispatch and delegated methods. member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2) { index$method_results <- list() + index$generic_returns <- list() backed <- names(index$properties)[vapply(index$properties, function(fields) { any(vapply(fields, function(value) { length(value$type) == 1L && @@ -596,14 +598,15 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 backed <- intersect(backed, names(index$classes)) if (!length(backed)) return(invisible(NULL)) candidates <- new.env(hash = TRUE, parent = emptyenv()) - add <- function(keys, type = NULL) { + add <- function(keys, type = NULL, generic = NULL) { for (key in unique(keys[!is.na(keys)])) { fn <- member_definition(index$definitions, key) if (!member_head(fn, "function")) next cost <- length(member_syntax_names(fn)) + length(fn[[2L]]) - if (cost < 6L) next + if (cost < 6L && is.null(generic)) next id <- if (is.null(type)) key else paste(type, key, sep = "|") - candidates[[id]] <- list(key = key, type = type, fn = fn) + item_generic <- if (is.null(generic)) candidates[[id]]$generic else generic + candidates[[id]] <- list(key = key, type = type, fn = fn, generic = item_generic) } } add(names(index$definitions)[vapply(index$definitions, function(fn) { @@ -616,7 +619,8 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 if (!member_head(fn, "function")) next generic <- s3_generic_descriptor(fn) if (!is.null(generic)) { - add(names(index$definitions)[startsWith(names(index$definitions), paste0(generic$name, "."))]) + methods <- names(index$definitions)[startsWith(names(index$definitions), paste0(generic$name, "."))] + add(methods, generic = generic$name) } } types <- intersect(names(index$members), names(index$classes)) @@ -687,6 +691,32 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 context = list(key = key, formals = names(fn[[2L]]), actuals = list())) used <- before - budget$remaining state$remaining <- state$remaining - used + if (!is.null(item$generic) && !budget$exhausted) { + candidate <- result + body <- fn[[3L]] + if (member_head(body, "{") && length(body) == 2L) body <- body[[2L]] + simple <- is.symbol(body) || member_head(body, "$") || member_head(body, "@") + if (!length(candidate$type) && simple && state$remaining > 0L) { + class <- substring(key, nchar(item$generic) + 2L) + if (class != "default") { + env[names(fn[[2L]])[[1L]]] <- list(member_value(type = class, + classes = member_lookup(index$classes, class))) + budget$remaining <- min(limit, state$remaining) + before <- budget$remaining + candidate <- member_infer(fn[[3L]], preparation_index, env, budget = budget, + context = list(key = key, formals = names(fn[[2L]]), actuals = list())) + state$remaining <- state$remaining - (before - budget$remaining) + } + } + if (!budget$exhausted && length(candidate$type) && !identical(candidate$type, ".never")) { + value <- if (length(candidate$type) == 1L && candidate$type %in% backed) { + member_value(type = candidate$type, classes = candidate$classes, member_package = index$package) + } else { + candidate + } + index$generic_returns[[item$generic]][key] <- list(value) + } + } if (!budget$exhausted && !isTRUE(result$open) && length(result$type) == 1L && result$type %in% backed) { # A wrapper may add instance fields beyond its declarative class. @@ -727,6 +757,17 @@ member_prepare_returns <- function(index, max_nodes = 40000L, max_bytes = 1024^2 prepare(item, 2048L) } } + # Suggestions describe known method outcomes, not a definite dispatch. + # Keep structural counterexamples so only their common members are offered. + for (generic in names(index$generic_returns)) { + values <- index$generic_returns[[generic]] + if (generic %in% index$generic_external || !any(vapply(values, function(value) any(value$type %in% backed), logical(1L)))) { + index$generic_returns[[generic]] <- NULL + } else { + index$generic_returns[[generic]] <- values[!duplicated(lapply(values, member_shape_key))] + } + } + if (as.numeric(utils::object.size(index$generic_returns)) > max_bytes) index$generic_returns <- list() index$return_definitions <- digest::digest(index$definitions, algo = "xxhash64") invisible(NULL) } diff --git a/R/member-inference.R b/R/member-inference.R index 0c1eb652..1c50e122 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -137,7 +137,7 @@ member_value <- function( metadata = NULL, slots = NULL, slot_types = NULL, s4_class = NULL, s4_generator = NULL, r6_private = NULL, r6_super = NULL, r6_self = NULL, r6_class = NULL, r6_role = NULL, default_dollar = FALSE, named_elements = FALSE, - member_package = NULL, column_names_only = FALSE + member_package = NULL, column_names_only = FALSE, possible_returns = NULL ) { value <- list( type = type, function_key = function_key, receiver = receiver, @@ -156,6 +156,7 @@ member_value <- function( if (isTRUE(named_elements)) value$named_elements <- TRUE if (!is.null(member_package)) value$member_package <- member_package if (isTRUE(column_names_only)) value$column_names_only <- TRUE + if (length(possible_returns)) value$possible_returns <- possible_returns value } @@ -1099,7 +1100,7 @@ member_infer <- function( } classes <- member_classes(input, index) if (!length(classes) || !length(generic)) { - return(member_value(reason = "open_dispatch")) + return(member_value(reason = "open_dispatch", possible_returns = member_lookup(index$generic_returns, generic))) } keys <- c(paste(generic, classes, sep = "."), paste0(generic, ".default")) keys <- keys[keys %in% names(index$definitions)] @@ -1449,6 +1450,21 @@ member_infer <- function( if (is.null(package_index)) { return(unknown) } + descriptor <- s3_generic_descriptor(member_definition(package_index$definitions, callee$function_key)) + if (!is.null(descriptor) && length(package_index$generic_returns[[descriptor$name]])) { + methods <- union(names(bindings), names(index$document_bindings)) + methods <- methods[startsWith(methods, paste0(descriptor$name, "."))] + at <- bindings$.__member_position__ + overridden <- any(methods %in% names(bindings)) || any(vapply(methods, function(method) { + history <- member_lookup(index$document_bindings, method) + length(history) && (is.null(at) || member_history_position(history, at) > 0L) + }, logical(1L))) + if (overridden) { + package_index <- list2env(as.list(package_index), parent = emptyenv()) + package_index$generic_returns[[descriptor$name]] <- NULL + package_index$cache <- new.env(parent = emptyenv()) + } + } env <- package_index$package_roots callee$metadata <- NULL env$.__member_callee__ <- callee diff --git a/R/member-metadata.R b/R/member-metadata.R index 7577f544..cf80eb0e 100644 --- a/R/member-metadata.R +++ b/R/member-metadata.R @@ -493,6 +493,7 @@ member_namespace_input <- function( lazy_names <- if (is.environment(lazydata)) setdiff(ls(lazydata, all.names = TRUE), blocked) else character() if (length(nms) + length(lazy_names) > 10000L) stop("Namespace exceeds metadata budget") definitions <- snapshots <- registries <- links <- descriptors <- s4_classes <- s4_roots <- s4_objects <- list() + generic_external <- character() s7_roots <- list() s7_modes <- member_s7_capabilities() functions <- values <- list() @@ -648,13 +649,29 @@ member_namespace_input <- function( }, error = function(e) member_snapshot_shape(list(kind = "unknown", reason = "dataset_metadata_error"), package)) }), lazy_names) subsets <- member_subset_registry(ns, package) + table <- member_binding(ns, ".__S3MethodsTable__.")[[2L]] + if (is.environment(table)) { + methods <- ls(table, all.names = TRUE) + for (name in intersect(exports, names(definitions))) { + generic <- s3_generic_descriptor(member_definition(definitions, name)) + if (is.null(generic)) next + for (method in methods[startsWith(methods, paste0(generic$name, "."))]) { + record <- member_binding(table, method, materialize = TRUE) + expected <- member_definition(definitions, method) + if (!identical(record[[1L]], "value") || typeof(record[[2L]]) != "closure" || + !identical(member_function_syntax(record[[2L]]), expected)) { + generic_external <- union(generic_external, generic$name) + } + } + } + } list( definitions = definitions, locations = list(), expressions = list(), exports = union(namespace_exports, union(lazy_names, names(targets)[targets %in% names(lazy_roots)])), namespace_exports = namespace_exports, namespace_export_targets = targets, namespace_lazydata_blocked = blocked, lazydata_roots = lazy_roots, registries = registries, - subset_registry = subsets$methods, subset_registry_complete = subsets$complete, + subset_registry = subsets$methods, subset_registry_complete = subsets$complete, generic_external = generic_external, snapshots = snapshots, links = links, descriptors = descriptors, package = package, intrinsics = intrinsics, s4_classes = s4_classes, s4_roots = s4_roots, s4_objects = s4_objects, s7_roots = s7_roots, s7_capabilities = s7_modes, @@ -695,10 +712,10 @@ member_index_thaw <- function(snapshot) { index } -member_prepare_package <- function(package, lib_paths = .libPaths(), context = NULL) { +member_prepare_package <- function(package, lib_paths = .libPaths(), context = NULL, identity = NULL) { .libPaths(lib_paths) ns <- asNamespace(package) - identity <- package_metadata_identity(package, lib_paths, context) + if (is.null(identity)) identity <- package_metadata_live_identity(package, lib_paths, context) cache_path <- package_metadata_cache_path("members", identity) cached <- package_metadata_cache_read(cache_path, identity, function(value) { identical(value$identity, identity) && !is.null(member_index_thaw(value)) @@ -747,7 +764,7 @@ member_prepare_startup_data <- function(packages, lib_paths = .libPaths(), cache ns <- asNamespace(package) lazydata <- member_namespace_lazydata(ns) if (!is.environment(lazydata) || !length(ls(lazydata, all.names = TRUE))) next - identity <- package_metadata_identity(package, lib_paths) + identity <- package_metadata_live_identity(package, lib_paths) path <- package_metadata_cache_path("startup-members", identity) cached <- package_metadata_cache_read(path, identity, function(value) { identical(value$identity, identity) && isTRUE(value$dataset_only) && !is.null(member_index_thaw(value)) @@ -785,9 +802,9 @@ member_resolve_packages <- function(pkgs, lib_paths, prepare = TRUE, namespace_p if ("S7" %in% loadedNamespaces()) context_packages <- sort(union(context_packages, "S7")) context <- package_metadata_context(context_packages) for (package in unique(c(setdiff(packages, startup_packages), namespace_packages))) { - identity <- tryCatch(package_metadata_identity(package, lib_paths, context), error = function(e) NULL) - if (!is.null(identity) && identical(known_members[[package]], identity)) next - snapshots[package] <- list(tryCatch(member_prepare_package(package, lib_paths, context), + identity <- tryCatch(package_metadata_live_identity(package, lib_paths, context), error = function(e) NULL) + if (isTRUE(context$cacheable) && !is.null(identity) && identical(known_members[[package]], identity)) next + snapshots[package] <- list(tryCatch(member_prepare_package(package, lib_paths, context, identity), error = function(e) { list( schema = 1L, roots = list(), namespace_roots = list(), diff --git a/R/package-cache.R b/R/package-cache.R index 5c87ee56..e687d7e0 100644 --- a/R/package-cache.R +++ b/R/package-cache.R @@ -12,6 +12,41 @@ package_metadata_identity <- function(package, lib_paths = .libPaths(), context files = digest::digest(list(files, info$size, as.numeric(info$mtime)), algo = "xxhash64"), context = context) } +package_metadata_signature <- function(value) { + if (is.call(value) || is.expression(value) || is.pairlist(value)) return(deparse1(value)) + if (is.list(value)) return(lapply(value, package_metadata_signature)) + value +} + +package_metadata_namespace_state <- function(ns) { + # Cache keys must describe the loaded values too: .onLoad(), tracing and + # package reinstalls can change them without changing an export's name. + dollar_context <- member_snapshot_dollar_context(ns) + modes <- member_s7_capabilities() + records <- lapply(ls(ns, all.names = TRUE), function(name) { + record <- member_binding(ns, name, materialize = TRUE) + value <- record[[2L]] + snapshot <- if (identical(record[[1L]], "value") && !is.object(value) && + is.atomic(value) && length(value) <= 256L) { + value + } else { + member_snapshot(value, max_bindings = 50000L, s7_modes = modes, lookup_scope = ns, + dollar_context = dollar_context) + } + list(name = name, kind = record[[1L]], value = digest::digest(package_metadata_signature(snapshot), algo = "xxhash64")) + }) + digest::digest(list(bindings = records, subsets = member_subset_registry(ns, unname(getNamespaceName(ns)))), + algo = "xxhash64") +} + +package_metadata_live_identity <- function(package, lib_paths = .libPaths(), context = NULL) { + identity <- package_metadata_identity(package, lib_paths, context) + identity$namespace <- package_metadata_namespace_state(asNamespace(package)) + identity +} + +package_metadata_cache_format <- 2L + package_metadata_cache_root <- function() { value <- getOption("languageserver.package_cache_dir", Sys.getenv("R_LANGSVR_PACKAGE_CACHE_DIR", tools::R_user_dir("languageserver", "cache"))) @@ -59,7 +94,8 @@ package_metadata_cache_server <- local({ package_metadata_cache_path <- function(type, identity, key = NULL) { directory <- package_metadata_cache_directory() if (is.null(directory)) return(NULL) - hash <- digest::digest(list(format = 1L, type = type, key = key, identity = identity, + if (is.list(identity$context) && identical(identity$context$cacheable, FALSE)) return(NULL) + hash <- digest::digest(list(format = package_metadata_cache_format, type = type, key = key, identity = identity, server = package_metadata_cache_server()), algo = "xxhash64") file.path(directory, paste0(identity$package, "-", type, "-", hash, ".rds")) } @@ -68,11 +104,14 @@ package_metadata_cache_read <- function(path, identity, validate = is.list) { if (is.null(path) || !file.exists(path)) return(NULL) tryCatch({ record <- readRDS(path) - if (!identical(record$format, 1L) || !identical(record$server, package_metadata_cache_server()) || + if (!identical(record$format, package_metadata_cache_format) || !identical(record$server, package_metadata_cache_server()) || !identical(record$identity, identity) || - !isTRUE(validate(record$value))) return(NULL) + !is.raw(record$payload) || + !identical(record$checksum, digest::digest(record$payload, algo = "xxhash64", serialize = FALSE))) return(NULL) + value <- unserialize(record$payload) + if (!isTRUE(validate(value))) return(NULL) suppressWarnings(Sys.setFileTime(path, Sys.time())) - record$value + value }, error = function(e) NULL) } @@ -84,7 +123,9 @@ package_metadata_cache_write <- function(path, identity, value) { directory <- dirname(path) dir.create(directory, recursive = TRUE, showWarnings = FALSE) temporary <- tempfile("metadata-", tmpdir = directory) - saveRDS(list(format = 1L, server = package_metadata_cache_server(), identity = identity, value = value), temporary) + payload <- serialize(value, NULL) + saveRDS(list(format = package_metadata_cache_format, server = package_metadata_cache_server(), identity = identity, + checksum = digest::digest(payload, algo = "xxhash64", serialize = FALSE), payload = payload), temporary) if (!file.rename(temporary, path)) { # Windows cannot replace an existing cache file with file.rename. # A racing reader can safely miss the cache and prepare its model. @@ -103,7 +144,10 @@ package_metadata_cache_write <- function(path, identity, value) { } package_metadata_context <- function(packages) { - list(packages = lapply(packages, function(package) { + identities <- lapply(packages, function(package) { tryCatch(package_metadata_identity(package), error = function(e) list(package = package, error = conditionMessage(e))) - }), bindings = s3_metadata_context(packages)) + }) + bindings <- s3_metadata_context(packages) + list(packages = identities, bindings = bindings, + cacheable = !is.null(bindings) && !any(vapply(identities, function(identity) !is.null(identity$error), logical(1L)))) } diff --git a/R/s3-metadata.R b/R/s3-metadata.R index 0d7c7e93..68862b61 100644 --- a/R/s3-metadata.R +++ b/R/s3-metadata.R @@ -318,19 +318,29 @@ s3_prepare_packages <- function(packages, cache_dir = package_metadata_cache_roo s3_metadata_context <- function(packages) { records <- lapply(packages, function(package) tryCatch({ ns <- asNamespace(package) - describe <- function(scope, names) stats::setNames(lapply(names, function(name) { - record <- member_binding(scope, name, materialize = TRUE) + describe <- function(scope, names, exported = FALSE) stats::setNames(lapply(names, function(name) { + record <- if (exported) s3_namespace_binding(scope, name) else member_binding(scope, name, materialize = TRUE) value <- record[[2L]] owner <- if (typeof(value) == "closure" && isNamespace(environment(value))) { unname(getNamespaceName(environment(value))) } - list(kind = record[[1L]], owner = owner, syntax = if (typeof(value) == "closure") member_function_syntax(value), + list(kind = record[[1L]], owner = owner, syntax = if (typeof(value) == "closure") deparse1(member_function_syntax(value)), primitive = if (is.primitive(value)) name) }), names) table <- member_binding(ns, ".__S3MethodsTable__.")[[2L]] - list(exports = describe(ns, getNamespaceExports(ns)), + lazy <- tryCatch(getNamespaceInfo(ns, "lazydata"), error = function(e) NULL) + objects <- unique(c(if (package == "datasets") getNamespaceExports(ns), names(lazy))) + shapes <- stats::setNames(lapply(objects, function(name) { + record <- s3_namespace_binding(ns, name) + if (!identical(record[[1L]], "value") && is.environment(lazy) && name %in% names(lazy)) { + record <- member_binding(lazy, name, materialize = TRUE) + } + if (identical(record[[1L]], "value")) s3_runtime_shape(record[[2L]]) + }), objects) + list(exports = describe(ns, getNamespaceExports(ns), exported = TRUE), objects = shapes, methods = if (is.environment(table) && length(table)) describe(table, ls(table, all.names = TRUE))) }, error = function(e) list(error = conditionMessage(e)))) + if (any(vapply(records, function(record) !is.null(record$error), logical(1L)))) return(NULL) digest::digest(records, algo = "xxhash64") } diff --git a/README.md b/README.md index 5f42d321..e50d980c 100644 --- a/README.md +++ b/README.md @@ -301,9 +301,13 @@ will turn off snippet support globally. LSP configuration settings are always ov Package member models, startup datasets, S3 catalogs, documentation summaries and rendered help share a persistent cache under `tools::R_user_dir("languageserver", "cache")`. It keeps up to 512 entries and 256 MiB, removing older entries as needed. Package -file, dependency, registry, R version and server implementation changes invalidate +file, loaded namespace, dependency, registry, R version and server implementation changes invalidate cached results; incompatible or corrupt entries are rebuilt. Document-dependent inference remains local to the current document and its metadata revision. +Conversions with unresolved input classes can offer the common members of known +method results as suggestions, marked `[possible receiver]` or `[possible member]`. +These suggestions do not establish the receiver's type; known conflicting method +outcomes and local method overrides suppress them. Set `options(languageserver.package_cache_dir = "/path/to/cache")` or the `R_LANGSVR_PACKAGE_CACHE_DIR` environment variable to choose another cache root; set `options(languageserver.package_cache_dir = FALSE)` to disable disk caching. diff --git a/tests/testthat/test-member-generic-suggestions.R b/tests/testthat/test-member-generic-suggestions.R new file mode 100644 index 00000000..d430568c --- /dev/null +++ b/tests/testthat/test-member-generic-suggestions.R @@ -0,0 +1,39 @@ +test_that("Unknown generic inputs offer common known members without claiming a type", { + code <- paste(c( + "native_box <- function(pointer) {box <- new.env(); box$step <- make_step(pointer); class(box) <- \"raw_box\"; box}", + "make_step <- function(pointer) function() native_box(.Call(\"never\", pointer))", + "adapt <- function(x) UseMethod(\"adapt\")", + "adapt.raw_box <- function(x) {box <- new.env(); box$raw <- x; class(box) <- \"public_box\"; box}", + "convert <- function(x) UseMethod(\"convert\")", + "convert.default <- function(x) adapt(native_box(.Call(\"never\", x)))", + "convert.data.frame <- function(x) adapt(native_box(.Call(\"never\", x)))" + ), collapse = "\n") + ns <- new.env(parent = baseenv()) + eval(parse(text = code), ns) + make_metadata <- function() { + metadata <- MemberMetadataCache$new(1024^2) + index <- member_package_index(member_namespace_input(ns, package = "suggestionfixture", exports = "convert")) + metadata$set("suggestionfixture", member_index_freeze(index)) + metadata + } + resolve <- function(lines, metadata) { + document <- Document$new("file:///generic-suggestion.R", language = "r", version = 1L, content = lines) + document$parse_data <- parse_document(document$uri, lines) + point <- list(row = length(lines) - 1L, col = nchar(tail(lines, 1L))) + workspace <- list(member_metadata = metadata) + resolved <- member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) + items <- member_completion(document$uri, workspace, document, point, TRUE, 200L) + list(value = resolved$value, items = items) + } + lines <- c("library(suggestionfixture)", "input <- opaque_source()", "converted <- convert(input)", "converted$") + metadata <- make_metadata() + result <- resolve(lines, metadata) + expect_null(result$value$type) + expect_identical(result$value$reason, "open_dispatch") + expect_identical(vapply(result$items, `[[`, character(1L), "label"), "raw") + expect_true(isTRUE(attr(result$items, "truncated"))) + overridden <- append(lines, "convert.custom <- function(x) list(other = TRUE)", after = 0L) + expect_length(resolve(overridden, metadata)$items, 0L) + ns$convert.custom <- function(x) list(other = TRUE) + expect_length(resolve(lines, make_metadata())$items, 0L) +}) diff --git a/tests/testthat/test-member-reuse-budget.R b/tests/testthat/test-member-reuse-budget.R index 69e8b1a5..561dc70e 100644 --- a/tests/testthat/test-member-reuse-budget.R +++ b/tests/testthat/test-member-reuse-budget.R @@ -4,7 +4,8 @@ test_that("Package preparation reuses unchanged models and refreshes changed dep identity <- function(package, ...) list(package = package, revision = revisions[[package]]) testthat::local_mocked_bindings( resolve_attached_packages = function(...) names(revisions), - package_metadata_identity = identity, + package_metadata_context = function(...) list(cacheable = TRUE), + package_metadata_live_identity = identity, member_prepare_package = function(package, ...) { prepared <<- c(prepared, package) list(identity = identity(package)) @@ -69,3 +70,35 @@ test_that("Timed-out member receivers retry with more time and cache successful expect_identical(names(resolve()$value$fields), "beta") expect_identical(tail(limits, 2L), c(0.25, 0.5)) }) + +test_that("Adaptive retries share the original node allowance", { + metadata <- MemberMetadataCache$new(1024^2) + content <- c("x <- list(alpha = TRUE)", "x$") + document <- Document$new("file:///adaptive-nodes.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + budget_factory <- member_request_budget + calls <- 0L + allowances <- integer() + testthat::local_mocked_bindings( + member_request_budget = function() { + budget <- budget_factory() + budget$time_limit <- 0.25 + budget$remaining <- 100L + budget + }, + member_cursor_value = function(parsed, sentinel, index, bindings, budget, ...) { + calls <<- calls + 1L + allowances <<- c(allowances, budget$remaining) + if (calls == 1L) { + budget$remaining <- 7L + budget$exhausted <- budget$timed_out <- TRUE + member_value(reason = "budget") + } else { + member_value(type = "list", fields = list(alpha = member_literal(TRUE))) + } + }, .package = "languageserver") + point <- list(row = 1L, col = 2L) + result <- member_resolve_cursor(document$uri, list(member_metadata = metadata), document, point, member_cursor(document, point)) + expect_identical(allowances, c(100L, 7L)) + expect_identical(result$value$type, "list") +}) diff --git a/tests/testthat/test-package-metadata-cache.R b/tests/testthat/test-package-metadata-cache.R index 4e2a1037..2e208852 100644 --- a/tests/testthat/test-package-metadata-cache.R +++ b/tests/testthat/test-package-metadata-cache.R @@ -28,8 +28,7 @@ test_that("Persistent package models survive reads and recover from corrupt cach expect_null(package_metadata_cache_read(path, first$identity)) third <- member_prepare_package("collections") expect_identical(prepared, 2L) - expect_identical(third$identity, first$identity) - expect_identical(package_metadata_cache_read(path, first$identity), third) + expect_identical(package_metadata_cache_read(package_metadata_cache_path("members", third$identity), third$identity), third) changed <- member_prepare_package("collections", context = "changed_namespace_context") expect_identical(prepared, 3L) expect_false(identical(changed$identity, first$identity)) @@ -54,15 +53,63 @@ test_that("Cache types, format revisions and server versions remain isolated", { expect_identical(package_metadata_cache_read(path, identity), list(value = "valid")) expect_null(package_metadata_cache_read(path, identity, is.character)) record <- readRDS(path) + record$payload <- serialize(list(value = "silently modified"), NULL) + saveRDS(record, path) + expect_null(package_metadata_cache_read(path, identity)) + expect_null(package_metadata_cache_path("s3", list(package = "fixture", context = list(cacheable = FALSE)))) + record$payload <- serialize(list(value = "valid"), NULL) record$format <- 999L saveRDS(record, path) expect_null(package_metadata_cache_read(path, identity)) - record$format <- 1L + record$format <- package_metadata_cache_format record$server$version <- "999.0.0" saveRDS(record, path) expect_null(package_metadata_cache_read(path, identity)) }) +test_that("Loaded namespace changes cannot poison models for another library", { + root <- withr::local_tempdir() + withr::local_options(languageserver.package_cache_dir = file.path(root, "cache")) + original <- .libPaths() + withr::defer(.libPaths(original)) + package <- "lscachefixture" + withr::defer(if (package %in% loadedNamespaces()) unloadNamespace(package)) + install <- function(field, lib) { + dir.create(lib) + source <- file.path(root, paste0("source-", field)) + dir.create(source) + dir.create(file.path(source, "R")) + writeLines(c("Package: lscachefixture", "Version: 0.0.1", "Title: Cache Test Fixture", + "Description: Test package metadata cache invalidation.", "License: MIT", + "Author: Test", "Maintainer: Test "), file.path(source, "DESCRIPTION")) + writeLines("export(api)", file.path(source, "NAMESPACE")) + writeLines(paste0("api <- list(", field, " = TRUE)"), file.path(source, "R", "api.R")) + result <- callr::rcmd("INSTALL", cmdargs = c(paste0("--library=", lib), source), + stdout = "|", stderr = "|", system_profile = FALSE, user_profile = FALSE) + expect_identical(result$status, 0L) + } + first_lib <- file.path(root, "first") + second_lib <- file.path(root, "second") + install("old", first_lib) + install("new", second_lib) + .libPaths(c(first_lib, original)) + first <- member_prepare_package(package) + expect_identical(names(first$roots$api$fields), "old") + second <- member_prepare_package(package, c(second_lib, original)) + expect_identical(names(second$roots$api$fields), "old") + unloadNamespace(package) + third <- member_prepare_package(package, c(second_lib, original)) + expect_identical(names(third$roots$api$fields), "new") + expect_false(identical(second$identity$namespace, third$identity$namespace)) + ns <- asNamespace(package) + unlockBinding("api", ns) + assign("api", list(runtime = TRUE), ns) + lockBinding("api", ns) + changed <- member_prepare_package(package, c(second_lib, original)) + expect_identical(names(changed$roots$api$fields), "runtime") + expect_false(identical(changed$identity$namespace, third$identity$namespace)) +}) + test_that("S3 catalogs reuse cached metadata and detect registry changes", { withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) prepared <- character() @@ -72,9 +119,10 @@ test_that("S3 catalogs reuse cached metadata and detect registry changes", { prepare(package) }, .package = "languageserver") first <- s3_prepare_packages("datasets") - expect_true(length(prepared) > 0L) + initial_preparations <- length(prepared) prepared <- character() second <- s3_prepare_packages("datasets") + expect_true(initial_preparations > 0L) expect_length(prepared, 0L) expect_identical(second, first) table <- get(".__S3MethodsTable__.", asNamespace("base")) diff --git a/tests/testthat/test-polars-dataframe-completion.R b/tests/testthat/test-polars-dataframe-completion.R index 1ab78c71..96c1f274 100644 --- a/tests/testthat/test-polars-dataframe-completion.R +++ b/tests/testthat/test-polars-dataframe-completion.R @@ -38,6 +38,15 @@ test_that("Polars conversions and later roots complete within a small inference } } remaining <- 512L + content <- c("library(polars)", "upstream <- opaque_source()", "converted <- as_polars_df(upstream)", "converted$") + document <- Document$new("file:///polars-unknown-input.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + point <- list(row = 3L, col = nchar(content[[4L]])) + resolved <- member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) + expect_null(resolved$value$type) + items <- member_completion(document$uri, workspace, document, point, TRUE, 200L) + expect_true(all(c("filter", "lazy", "select") %in% vapply(items, `[[`, character(1L), "label"))) + expect_true(isTRUE(attr(items, "truncated"))) for (expression in c( 'dt$filter(pl$col("a") > pl$col("b")$|)', 'dt$filter(pl$col("a") > pl$col("b")$me|an())', From a566d9f8c749e656273c787b42fac456dc7895c2 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 00:49:18 +0800 Subject: [PATCH 05/12] Share possible receiver members with signature help and hover --- NEWS.md | 2 + R/member-completion.R | 25 +++++---- R/member-inference.R | 26 +++++++++ R/member-providers.R | 7 ++- README.md | 3 +- .../test-member-generic-suggestions.R | 55 ++++++++++++++++++- .../test-polars-dataframe-completion.R | 11 ++++ 7 files changed, 116 insertions(+), 13 deletions(-) diff --git a/NEWS.md b/NEWS.md index 0a01d748..ec500d22 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,8 @@ within a one-second total deadline and the original node allowance. Offer common known method members as possible-receiver suggestions when a conversion's input class is unresolved, without claiming a definite type. + Share these possible receivers with signature help and hover when the member + implementation is unambiguous, and display an uncertainty note. - Persist package member models, startup datasets, S3 catalogs, documentation summaries and rendered help in a shared bounded cache. Reuse unchanged models diff --git a/R/member-completion.R b/R/member-completion.R index d93488f1..50931ed9 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -913,12 +913,21 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name } if (!is.null(cursor$accessor) && !is.null(name)) { receiver <- value + possible <- member_possible_receiver(receiver, index, bindings, cursor$accessor) + if (!is.null(possible)) { + if (!name %in% possible$members || name %in% possible$ambiguous) { + return(list(value = member_value(reason = "ambiguous_possible_member"), + index = index, bindings = bindings, budget = budget)) + } + receiver <- possible$value + } value <- if (identical(cursor$accessor, "@")) member_slot(receiver, name, index, bindings, budget) else member_access(receiver, name, index, bindings) key <- member_members(receiver, index, bindings, cursor$accessor)[name] if (is.null(value$function_key) && length(key) && !is.na(key[[1L]]) && !is.null(value$function_expr)) { value$function_key <- key[[1L]] } + if (!is.null(possible)) value$possible_receiver <- TRUE } if (isTRUE(budget$timed_out) && budget$remaining > 0L && budget$time_limit < 1 && is.null(retry_deadline) && proc.time()[[3L]] < ceiling) { @@ -955,20 +964,16 @@ member_completion <- function(uri, workspace, document, point, snippet_support, return(NULL) } value <- resolved$value - possible <- !length(value$type) && length(value$possible_returns) + candidate <- member_possible_receiver(value, resolved$index, resolved$bindings, cursor$accessor) + possible <- !is.null(candidate) common <- NULL ambiguous <- character() if (possible) { - sets <- lapply(value$possible_returns, function(candidate) member_members(candidate, resolved$index, resolved$bindings)) - common <- Reduce(intersect, lapply(sets, names)) + sets <- candidate$sets + common <- candidate$members if (!length(common)) return(list()) - owners <- vapply(value$possible_returns, function(candidate) { - if (is.null(candidate$member_package)) "" else candidate$member_package - }, character(1L)) - ambiguous <- common[vapply(common, function(name) { - length(unique(owners)) > 1L || !all(vapply(sets, function(set) identical(set[[name]], sets[[1L]][[name]]), logical(1L))) - }, logical(1L))] - value <- value$possible_returns[[1L]] + ambiguous <- candidate$ambiguous + value <- candidate$value } index <- member_package_context(resolved$index, value$member_package) bindings <- resolved$bindings diff --git a/R/member-inference.R b/R/member-inference.R index 1c50e122..884421e2 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -307,6 +307,32 @@ member_members <- function(value, index, bindings = list(), accessor = "$") { out } +# Possible receivers keep their inferred type unresolved. All providers use +# the same intersection and reject conflicting member implementations. +member_possible_receiver <- function(value, index, bindings = list(), accessor = "$") { + if (length(value$type) || !length(value$possible_returns)) return(NULL) + candidates <- value$possible_returns + sets <- lapply(candidates, function(candidate) member_members(candidate, index, bindings, accessor)) + common <- Reduce(intersect, lapply(sets, names)) + owners <- vapply(candidates, function(candidate) { + if (is.null(candidate$member_package)) "" else candidate$member_package + }, character(1L)) + ambiguous <- common[vapply(common, function(name) { + if (length(unique(owners)) > 1L || !all(vapply(sets, function(set) identical(set[[name]], sets[[1L]][[name]]), logical(1L)))) { + return(TRUE) + } + if (all(vapply(sets, function(set) is.na(set[[name]]), logical(1L)))) { + fields <- lapply(candidates, function(candidate) { + if (identical(accessor, "@")) member_slot(candidate, name, index, bindings) else + member_access(candidate, name, index, bindings) + }) + return(!all(vapply(fields, identical, logical(1L), fields[[1L]]))) + } + FALSE + }, logical(1L))] + list(value = candidates[[1L]], members = common, ambiguous = ambiguous, sets = sets) +} + # A bounded structural cache key omits irrelevant literals/large closure maps. # Function identity and the metadata generation isolate package summaries. member_shape_key <- function(value, depth = 0L) { diff --git a/R/member-providers.R b/R/member-providers.R index cf10a48d..fc244f30 100644 --- a/R/member-providers.R +++ b/R/member-providers.R @@ -15,10 +15,15 @@ member_symbol_info <- function(label, value, key, index) { signature <- if (member_head(fn, "function")) get_signature(display, fn) else NULL delegated <- member_lookup(index$delegation, key) if (!is.null(delegated)) key <- delegated$original + description <- member_r6_description(value) + if (isTRUE(value$possible_receiver)) { + description <- paste(c("Receiver type is uncertain; this member is shared by known method results.", description), + collapse = "\n\n") + } list( label = label, signature = signature, function_id = key, package = index$package, value = value, - description = member_r6_description(value) + description = description ) } diff --git a/README.md b/README.md index e50d980c..3ab9b03a 100644 --- a/README.md +++ b/README.md @@ -307,7 +307,8 @@ inference remains local to the current document and its metadata revision. Conversions with unresolved input classes can offer the common members of known method results as suggestions, marked `[possible receiver]` or `[possible member]`. These suggestions do not establish the receiver's type; known conflicting method -outcomes and local method overrides suppress them. +outcomes and local method overrides suppress them. Signature help and hover also +use unambiguous common members and display a note when the receiver is uncertain. Set `options(languageserver.package_cache_dir = "/path/to/cache")` or the `R_LANGSVR_PACKAGE_CACHE_DIR` environment variable to choose another cache root; set `options(languageserver.package_cache_dir = FALSE)` to disable disk caching. diff --git a/tests/testthat/test-member-generic-suggestions.R b/tests/testthat/test-member-generic-suggestions.R index d430568c..9e35d831 100644 --- a/tests/testthat/test-member-generic-suggestions.R +++ b/tests/testthat/test-member-generic-suggestions.R @@ -1,9 +1,13 @@ test_that("Unknown generic inputs offer common known members without claiming a type", { code <- paste(c( + "commands <- new.env(parent = emptyenv())", "native_box <- function(pointer) {box <- new.env(); box$step <- make_step(pointer); class(box) <- \"raw_box\"; box}", "make_step <- function(pointer) function() native_box(.Call(\"never\", pointer))", "adapt <- function(x) UseMethod(\"adapt\")", "adapt.raw_box <- function(x) {box <- new.env(); box$raw <- x; class(box) <- \"public_box\"; box}", + "`$.public_box` <- function(x, name) {method_names <- names(commands); if(name %in% method_names) {f <- commands[[name]]; current <- x; environment(f) <- environment(); f} else NextMethod()}", + "step <- function(delta = 1, flag = TRUE) adapt(current$raw$step(delta))", + "commands$step <- step", "convert <- function(x) UseMethod(\"convert\")", "convert.default <- function(x) adapt(native_box(.Call(\"never\", x)))", "convert.data.frame <- function(x) adapt(native_box(.Call(\"never\", x)))" @@ -30,10 +34,59 @@ test_that("Unknown generic inputs offer common known members without claiming a result <- resolve(lines, metadata) expect_null(result$value$type) expect_identical(result$value$reason, "open_dispatch") - expect_identical(vapply(result$items, `[[`, character(1L), "label"), "raw") + expect_identical(vapply(result$items, `[[`, character(1L), "label"), c("raw", "step")) expect_true(isTRUE(attr(result$items, "truncated"))) + providers <- function(lines, metadata) { + document <- Document$new("file:///generic-provider.R", language = "r", version = 1L, content = lines) + data <- parse_document(document$uri, lines) + data$version <- 1L + document$update_parse_data(data) + workspace <- list(member_metadata = metadata, get_documentation = function(...) { + list(description = "Advance the object.", arguments = list(delta = "Step size.", flag = "A flag.")) + }) + row <- length(lines) - 1L + opening <- regexpr("(", tail(lines, 1L), fixed = TRUE)[[1L]] + list(signature = signature_reply(1L, document$uri, workspace, document, + list(row = row, col = opening))$result, + hover = hover_reply(1L, document$uri, workspace, document, list(row = row, col = 12L))$result) + } + calls <- lines + calls[[4L]] <- "converted$step()" + replies <- providers(calls, metadata) + expect_identical(replies$signature$signatures[[1L]]$label, "step(delta = 1, flag = TRUE)") + expect_match(replies$signature$signatures[[1L]]$documentation$value, "Receiver type is uncertain", fixed = TRUE) + expect_match(paste(replies$hover$contents, collapse = "\n"), "step(delta = 1, flag = TRUE)", fixed = TRUE) + expect_match(paste(replies$hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) overridden <- append(lines, "convert.custom <- function(x) list(other = TRUE)", after = 0L) expect_length(resolve(overridden, metadata)$items, 0L) + suppressed <- providers(append(calls, "convert.custom <- function(x) list(other = TRUE)", after = 0L), metadata) + expect_length(suppressed$signature$signatures, 0L) + expect_null(suppressed$hover) ns$convert.custom <- function(x) list(other = TRUE) expect_length(resolve(lines, make_metadata())$items, 0L) + suppressed <- providers(calls, make_metadata()) + expect_length(suppressed$signature$signatures, 0L) + expect_null(suppressed$hover) +}) + +test_that("Conflicting possible member signatures stay unresolved", { + index <- member_generic_index("first <- function(delta = 1) NULL\nsecond <- function(other = TRUE) NULL") + index$package <- "ambiguousfixture" + index$exports <- c("candidate", "first", "second") + index$members <- list(first_type = c(step = "first"), second_type = c(step = "second")) + index$roots$candidate <- member_value(reason = "open_dispatch", possible_returns = list( + member_value(type = "first_type", member_package = "ambiguousfixture"), + member_value(type = "second_type", member_package = "ambiguousfixture"))) + metadata <- MemberMetadataCache$new(1024^2) + metadata$set("ambiguousfixture", member_index_freeze(index)) + content <- c("library(ambiguousfixture)", "object <- candidate", "object$step()") + document <- Document$new("file:///ambiguous-member.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + workspace <- list(member_metadata = metadata) + items <- member_completion(document$uri, workspace, document, list(row = 2L, col = 11L), TRUE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), "step") + expect_identical(items[[1L]]$detail, "[possible member]") + signature <- signature_reply(1L, document$uri, workspace, document, list(row = 2L, col = 12L))$result + expect_length(signature$signatures, 0L) + expect_null(hover_reply(1L, document$uri, workspace, document, list(row = 2L, col = 9L))$result) }) diff --git a/tests/testthat/test-polars-dataframe-completion.R b/tests/testthat/test-polars-dataframe-completion.R index 96c1f274..75026dfc 100644 --- a/tests/testthat/test-polars-dataframe-completion.R +++ b/tests/testthat/test-polars-dataframe-completion.R @@ -47,6 +47,17 @@ test_that("Polars conversions and later roots complete within a small inference items <- member_completion(document$uri, workspace, document, point, TRUE, 200L) expect_true(all(c("filter", "lazy", "select") %in% vapply(items, `[[`, character(1L), "label"))) expect_true(isTRUE(attr(items, "truncated"))) + content[[4L]] <- "converted$filter()" + document$set_content(2L, content) + data <- parse_document(document$uri, content) + data$version <- 2L + document$update_parse_data(data) + signature <- signature_reply(1L, document$uri, workspace, document, list(row = 3L, col = 17L))$result + expect_identical(signature$signatures[[1L]]$label, "filter(...)") + expect_match(signature$signatures[[1L]]$documentation$value, "Receiver type is uncertain", fixed = TRUE) + hover <- hover_reply(1L, document$uri, workspace, document, list(row = 3L, col = 12L))$result + expect_match(paste(hover$contents, collapse = "\n"), "filter(...)", fixed = TRUE) + expect_match(paste(hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) for (expression in c( 'dt$filter(pl$col("a") > pl$col("b")$|)', 'dt$filter(pl$col("a") > pl$col("b")$me|an())', From 96d73987bbd6ca34ee8b892d29fe55e7859a6bfa Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 01:40:12 +0800 Subject: [PATCH 06/12] Preserve possible results through member calls and aliases --- NEWS.md | 3 +- R/member-inference.R | 38 ++++++++++++++++++- README.md | 2 + .../test-member-generic-suggestions.R | 28 +++++++++++++- .../test-polars-dataframe-completion.R | 20 ++++++++++ 5 files changed, 88 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index ec500d22..8dca1d09 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,7 +9,8 @@ common known method members as possible-receiver suggestions when a conversion's input class is unresolved, without claiming a definite type. Share these possible receivers with signature help and hover when the member - implementation is unambiguous, and display an uncertainty note. + implementation is unambiguous, and display an uncertainty note. Preserve + possible results through member calls and subsequent assignments and aliases. - Persist package member models, startup datasets, S3 catalogs, documentation summaries and rendered help in a shared bounded cache. Reuse unchanged models diff --git a/R/member-inference.R b/R/member-inference.R index 884421e2..3c757541 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -333,6 +333,20 @@ member_possible_receiver <- function(value, index, bindings = list(), accessor = list(value = candidates[[1L]], members = common, ambiguous = ambiguous, sets = sets) } +member_possible_result <- function(values) { + candidates <- list() + for (value in values) { + if (!length(value$type) && length(value$possible_returns)) { + candidates <- c(candidates, value$possible_returns) + } else if ((length(value$type) && !any(value$type %in% c(".never", ".missing"))) || + !is.null(value$function_key) || !is.null(value$function_expr) || !is.null(value$result_shape)) { + candidates <- c(candidates, list(value)) + } + } + candidates <- candidates[!duplicated(candidates)] + member_value(reason = "possible_result", possible_returns = candidates) +} + # A bounded structural cache key omits irrelevant literals/large closure maps. # Function identity and the metadata generation isolate package summaries. member_shape_key <- function(value, depth = 0L) { @@ -377,7 +391,7 @@ member_cacheable <- function(value, depth = 0L) { if (is.null(value)) { return(TRUE) } - if (depth > 4L || isTRUE(value$open) || !is.null(value$function_expr) || !is.null(value$closure) || + if (depth > 4L || isTRUE(value$open) || length(value$possible_returns) || !is.null(value$function_expr) || !is.null(value$closure) || !is.null(value$binding_expr)) { return(FALSE) } @@ -424,6 +438,14 @@ member_slot <- function(value, name, index, bindings, budget = NULL) { member_access <- function(lhs, name, index, bindings) { unknown <- member_value(reason = "unsupported") + if (is.null(name)) return(unknown) + possible <- member_possible_receiver(lhs, index, bindings) + if (!is.null(possible)) { + if (!name %in% possible$members) return(unknown) + return(member_possible_result(lapply(lhs$possible_returns, function(candidate) { + member_access(candidate, name, index, bindings) + }))) + } if (isTRUE(lhs$column_names_only) || identical(lhs$reason, "unresolved_dollar_dispatch")) { return(member_value(reason = "unresolved_dollar_dispatch")) } @@ -1458,6 +1480,20 @@ member_infer <- function( return(unknown) } if (is.null(callee)) callee <- infer(expr[[1L]]) + if (length(callee$possible_returns)) { + if (open_dots) return(unknown) + # Infer arguments once, then analyse each known callable against its + # own receiver. Results remain possibilities through further chains. + env <- bindings + for (i in seq_along(actuals)) env[paste0(".__possible_arg", i)] <- list(actuals[[i]]) + call <- as.call(c(list(as.name(".__possible_callee__")), + stats::setNames(lapply(seq_along(actuals), function(i) as.name(paste0(".__possible_arg", i))), names(actuals)))) + values <- lapply(callee$possible_returns, function(candidate) { + env$.__possible_callee__ <- candidate + member_infer(call, index, env, depth = depth + 1L, trail = trail, budget = budget) + }) + return(member_possible_result(values)) + } if (identical(callee$metadata, "S7") && callee$function_key %in% member_s7_intrinsics) { return(member_s7_call(expr, index, bindings, budget, callee$function_key)) } diff --git a/README.md b/README.md index 3ab9b03a..dc520f8d 100644 --- a/README.md +++ b/README.md @@ -309,6 +309,8 @@ method results as suggestions, marked `[possible receiver]` or `[possible member These suggestions do not establish the receiver's type; known conflicting method outcomes and local method overrides suppress them. Signature help and hover also use unambiguous common members and display a note when the receiver is uncertain. +Possible results propagate through member calls, assignments and aliases so +completion and provider information remain available on derived objects. Set `options(languageserver.package_cache_dir = "/path/to/cache")` or the `R_LANGSVR_PACKAGE_CACHE_DIR` environment variable to choose another cache root; set `options(languageserver.package_cache_dir = FALSE)` to disable disk caching. diff --git a/tests/testthat/test-member-generic-suggestions.R b/tests/testthat/test-member-generic-suggestions.R index 9e35d831..bf6bf73b 100644 --- a/tests/testthat/test-member-generic-suggestions.R +++ b/tests/testthat/test-member-generic-suggestions.R @@ -2,7 +2,7 @@ test_that("Unknown generic inputs offer common known members without claiming a code <- paste(c( "commands <- new.env(parent = emptyenv())", "native_box <- function(pointer) {box <- new.env(); box$step <- make_step(pointer); class(box) <- \"raw_box\"; box}", - "make_step <- function(pointer) function() native_box(.Call(\"never\", pointer))", + "make_step <- function(pointer) function(delta = 1) native_box(.Call(\"never\", pointer, delta))", "adapt <- function(x) UseMethod(\"adapt\")", "adapt.raw_box <- function(x) {box <- new.env(); box$raw <- x; class(box) <- \"public_box\"; box}", "`$.public_box` <- function(x, name) {method_names <- names(commands); if(name %in% method_names) {f <- commands[[name]]; current <- x; environment(f) <- environment(); f} else NextMethod()}", @@ -57,6 +57,18 @@ test_that("Unknown generic inputs offer common known members without claiming a expect_match(replies$signature$signatures[[1L]]$documentation$value, "Receiver type is uncertain", fixed = TRUE) expect_match(paste(replies$hover$contents, collapse = "\n"), "step(delta = 1, flag = TRUE)", fixed = TRUE) expect_match(paste(replies$hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) + chained <- append(lines[1:3], c("next_object <- converted$step(delta = 2)", "next_object$")) + result <- resolve(chained, metadata) + expect_null(result$value$type) + expect_identical(vapply(result$items, `[[`, character(1L), "label"), c("raw", "step")) + chained[[5L]] <- "next_object$step()" + # Use the same-width alias to check the named-member provider path. + chained <- append(chained[1:4], c("converted <- next_object", "converted$step()")) + replies <- providers(chained, metadata) + expect_identical(replies$signature$signatures[[1L]]$label, "step(delta = 1, flag = TRUE)") + expect_match(paste(replies$hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) + invalid <- append(lines[1:3], c("next_object <- converted$step(delta = 1, delta = 2)", "next_object$")) + expect_length(resolve(invalid, metadata)$items, 0L) overridden <- append(lines, "convert.custom <- function(x) list(other = TRUE)", after = 0L) expect_length(resolve(overridden, metadata)$items, 0L) suppressed <- providers(append(calls, "convert.custom <- function(x) list(other = TRUE)", after = 0L), metadata) @@ -69,6 +81,20 @@ test_that("Unknown generic inputs offer common known members without claiming a expect_null(suppressed$hover) }) +test_that("Call summaries do not mix different possible argument receivers", { + index <- member_generic_index(paste(c( + "transform <- function(input) input$run()", + "first_result <- function() list(first = TRUE)", + "second_result <- function() list(second = TRUE)" + ), collapse = "\n")) + index$members <- list(first_type = c(run = "first_result"), second_type = c(run = "second_result")) + possible <- function(type) member_value(reason = "open_dispatch", possible_returns = list(member_value(type = type))) + first <- member_infer(quote(transform(input)), index, list(input = possible("first_type"))) + second <- member_infer(quote(transform(input)), index, list(input = possible("second_type"))) + expect_identical(names(first$possible_returns[[1L]]$fields), "first") + expect_identical(names(second$possible_returns[[1L]]$fields), "second") +}) + test_that("Conflicting possible member signatures stay unresolved", { index <- member_generic_index("first <- function(delta = 1) NULL\nsecond <- function(other = TRUE) NULL") index$package <- "ambiguousfixture" diff --git a/tests/testthat/test-polars-dataframe-completion.R b/tests/testthat/test-polars-dataframe-completion.R index 75026dfc..8be43894 100644 --- a/tests/testthat/test-polars-dataframe-completion.R +++ b/tests/testthat/test-polars-dataframe-completion.R @@ -58,6 +58,26 @@ test_that("Polars conversions and later roots complete within a small inference hover <- hover_reply(1L, document$uri, workspace, document, list(row = 3L, col = 12L))$result expect_match(paste(hover$contents, collapse = "\n"), "filter(...)", fixed = TRUE) expect_match(paste(hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) + remaining <- 2048L + content <- c("library(polars)", 'dt <- fst::read_fst("test.fst")', "dt1 <- as_polars_df(dt)", + "dt2 <- dt1$select(", ' "x", "y",', ' (pl$col("x") / pl$col("y"))$alias("ratio")', ")", "dt2$") + document <- Document$new("file:///polars-chained-input.R", language = "r", version = 1L, content = content) + document$parse_data <- parse_document(document$uri, content) + point <- list(row = 7L, col = 4L) + resolved <- member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) + expect_null(resolved$value$type) + items <- member_completion(document$uri, workspace, document, point, TRUE, 200L) + expect_true(all(c("filter", "lazy", "select") %in% vapply(items, `[[`, character(1L), "label"))) + content[[8L]] <- "dt2$filter()" + document$set_content(2L, content) + data <- parse_document(document$uri, content) + data$version <- 2L + document$update_parse_data(data) + signature <- signature_reply(1L, document$uri, workspace, document, list(row = 7L, col = 11L))$result + expect_identical(signature$signatures[[1L]]$label, "filter(...)") + hover <- hover_reply(1L, document$uri, workspace, document, list(row = 7L, col = 6L))$result + expect_match(paste(hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) + remaining <- 512L for (expression in c( 'dt$filter(pl$col("a") > pl$col("b")$|)', 'dt$filter(pl$col("a") > pl$col("b")$me|an())', From ce7276c90eedbce82bb7bc82a6cc8ac39ba09cd2 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 08:52:17 +0800 Subject: [PATCH 07/12] Adapt member inference to CPU contention and cache uncertain receivers --- NEWS.md | 6 +- R/document.R | 2 - R/member-analysis.R | 21 ++- R/member-completion.R | 57 ++++--- R/member-inference.R | 5 +- R/member-s4.R | 4 +- README.md | 8 +- tests/testthat/test-member-analysis.R | 14 +- tests/testthat/test-member-completion.R | 5 +- tests/testthat/test-member-reuse-budget.R | 193 +++++++++++++++------- 10 files changed, 216 insertions(+), 99 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8dca1d09..bab74167 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,8 +4,10 @@ `dt <- as_polars_df(iris)` and for `pl$` after calls using the converted frame. Prepare bounded S3 method return summaries with their owning namespace. Retain namespace ownership through chained methods and nested argument - expressions. Retry timed-out member requests with an adaptive allowance - within a one-second total deadline and the original node allowance. Offer + expressions. Extend cold member analysis in place from 250 ms up to two + seconds of CPU time, allowing up to five seconds elapsed on busy hosts. + Retain node and depth bounds and cache completed uncertain receivers for + repeated completion, signature help and hover requests. Offer common known method members as possible-receiver suggestions when a conversion's input class is unresolved, without claiming a definite type. Share these possible receivers with signature help and hover when the member diff --git a/R/document.R b/R/document.R index 3a140be7..9da1b1e8 100644 --- a/R/document.R +++ b/R/document.R @@ -22,7 +22,6 @@ Document <- R6::R6Class( requested_packages = NULL, member_refresh = FALSE, member_receivers = NULL, - member_budgets = NULL, s3_calls = NULL, s3_identity = NULL, member_revision = NULL, @@ -38,7 +37,6 @@ Document <- R6::R6Class( self$version <- version self$is_rmarkdown <- is_rmarkdown(uri, language) self$member_receivers <- ByteLruCache$new(4 * 1024^2, max_entries = 32L) - self$member_budgets <- ByteLruCache$new(16384L, max_entries = 32L) self$s3_calls <- ByteLruCache$new(1 * 1024^2, max_entries = 32L) self$set_content(version, content) self$loaded_packages <- character() diff --git a/R/member-analysis.R b/R/member-analysis.R index 3f4e8435..a97e8f6d 100644 --- a/R/member-analysis.R +++ b/R/member-analysis.R @@ -94,8 +94,11 @@ member_completion_value <- function(value, index, budget) { } member_receiver_cacheable <- function(value, index, budget) { - if (isTRUE(budget$exhausted) || !length(value$type)) return(FALSE) + if (isTRUE(budget$exhausted) || (!length(value$type) && !length(value$possible_returns))) return(FALSE) if (!isTRUE(budget$transient)) return(TRUE) + if (!length(value$type)) { + return(all(vapply(value$possible_returns, member_receiver_cacheable, logical(1L), index, budget))) + } # Recursive argument analysis must not preserve partial instance fields. # A native-backed class-only result has a complete declared member surface # independent of argument values; retain just that proven surface. @@ -109,3 +112,19 @@ member_receiver_cacheable <- function(value, index, budget) { any(index$members[[property$type]] %in% index$native_factories, na.rm = TRUE) }, logical(1L)))) } + +member_receiver_cache_value <- function(value, index, budget) { + if (member_receiver_cacheable(value, index, budget)) return(value) + if (isTRUE(budget$exhausted) || !isTRUE(budget$transient) || + length(value$type) || !length(value$possible_returns)) return(NULL) + # A possible native result may carry argument-dependent instance fields. + # Its declared surface is still useful, but those partial fields cannot be + # retained. The existing native-surface check verifies every projection. + candidates <- lapply(value$possible_returns, function(candidate) { + candidate$fields <- NULL + if (member_receiver_cacheable(candidate, index, budget)) candidate else NULL + }) + if (any(vapply(candidates, is.null, logical(1L)))) return(NULL) + value$possible_returns <- candidates + value +} diff --git a/R/member-completion.R b/R/member-completion.R index 50931ed9..0dc4fbf1 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -483,7 +483,8 @@ member_context_index <- function(workspace, uri, document, at, parsed = NULL, } member_resolve_document <- function(name, index, bindings, budget, depth, trail) { - if (depth > 64L) return(member_value(reason = "binding_recursion")) + limit <- if (is.null(budget$depth_limit)) 64L else budget$depth_limit + if (depth > limit) return(member_value(reason = "binding_recursion")) history <- index$document_bindings[[name]] at <- bindings$.__member_position__ if (is.null(at)) at <- c(Inf, Inf) @@ -517,7 +518,10 @@ member_resolve_document <- function(name, index, bindings, budget, depth, trail) depth = depth + 1L, trail = c(trail, id), budget = budget ) - if (memo && length(value$type) && !budget$exhausted && !budget$transient) index$document_cache[[memo_key]] <- value + cached <- if (memo) member_receiver_cache_value(value, index, budget) else NULL + if (!is.null(cached)) { + index$document_cache[[memo_key]] <- cached + } value } @@ -844,8 +848,7 @@ member_recover_scope <- function(document, point, cursor, data) { member_recover(document, point, cursor, data) } -member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL, retry_deadline = NULL, - remaining_nodes = NULL) { +member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL) { if (!identical(document$version, document$parse_data$version) && !is.null(document$parse_data$version)) { return(NULL) @@ -858,7 +861,6 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name return(NULL) } budget <- member_request_budget() - if (!is.null(remaining_nodes)) budget$remaining <- min(budget$remaining, remaining_nodes) metadata <- workspace$member_metadata cache <- document$member_receivers revision <- if (is.null(metadata)) 0L else if (is.function(metadata$revision)) metadata$revision() else NULL @@ -866,15 +868,8 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name revision = revision) if (!identical(document$member_revision, identity)) { cache$clear() - document$member_budgets$clear() document$member_revision <- identity } - budget_key <- paste(point$row, cursor$operator_row, cursor$operator, cursor$accessor, sep = ":") - if (!is.null(budget$time_limit) && budget$time_limit < 1) { - ceiling <- if (is.null(retry_deadline)) proc.time()[[3L]] + 1 else retry_deadline - budget$time_limit <- document$member_budgets$get(budget_key, budget$time_limit) - budget$deadline <- min(proc.time()[[3L]] + budget$time_limit, ceiling) - } # The receiver does not depend on the member prefix or the call arguments # after it. Edits and accepted parses clear this document-local cache. key <- paste(point$row, cursor$start, cursor$end, cursor$operator_row, @@ -903,10 +898,11 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name value <- member_cursor_value(recovered$parsed, recovered$sentinel, index, bindings, budget, if (is.null(cursor$accessor)) name, cursor$accessor, recovered$context, recovered$path, recovered$source) - if (!is.null(revision) && member_receiver_cacheable(value, index, budget)) { + cached_value <- if (!is.null(revision)) member_receiver_cache_value(value, index, budget) else NULL + if (!is.null(cached_value)) { # Raw storage accounts for closure environments and makes each # hit independent of mutable request-local binding memos. - record <- serialize(list(value = value, bindings = bindings, + record <- serialize(list(value = cached_value, bindings = bindings, start = recovered$start, referenced = referenced), NULL) cache$set(key, record) } @@ -929,20 +925,15 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name } if (!is.null(possible)) value$possible_receiver <- TRUE } - if (isTRUE(budget$timed_out) && budget$remaining > 0L && budget$time_limit < 1 && is.null(retry_deadline) && - proc.time()[[3L]] < ceiling) { - # Retry a timed-out receiver once using reusable package summaries. - # Learn a larger allowance for this cursor, capped at one second total. - document$member_budgets$set(budget_key, min(1, budget$time_limit * 2)) - return(member_resolve_cursor(uri, workspace, document, point, cursor, name, retry_deadline = ceiling, - remaining_nodes = budget$remaining)) - } list(value = value, index = index, bindings = bindings, budget = budget) } member_request_budget <- function() { budget <- new.env(parent = emptyenv()) budget$remaining <- 20000L + # Assignment histories add depth without adding recursive function calls. + # Keep a finite stack bound while allowing longer reassigned query chains. + budget$depth_limit <- 128L budget$exhausted <- budget$transient <- FALSE # Parallel tests compete with parse/metadata workers; coverage also rewrites # byte-compiled functions. Allow that overhead while keeping all bounds. @@ -953,10 +944,30 @@ member_request_budget <- function() { } else { 0.25 } - budget$deadline <- proc.time()[[3L]] + budget$time_limit + clock <- proc.time() + budget$started <- clock[[3L]] + budget$cpu_started <- clock[[1L]] + clock[[2L]] + budget$deadline <- budget$scheduled_deadline <- budget$started + budget$time_limit + budget$cpu_limit <- max(2, budget$time_limit) + budget$wall_deadline <- budget$started + max(5, budget$time_limit) budget } +# Grow the allowance at existing clock checkpoints, without restarting the +# traversal or replenishing nodes. CPU time distinguishes slow analysis from +# time spent descheduled on a busy host; a wall deadline still bounds latency. +# Explicit caller deadlines remain strict and never receive an extension. +member_budget_expired <- function(budget, clock) { + if (clock[[3L]] <= budget$deadline) return(FALSE) + if (is.null(budget$scheduled_deadline) || !identical(budget$deadline, budget$scheduled_deadline)) return(TRUE) + cpu <- max(0, clock[[1L]] + clock[[2L]] - budget$cpu_started) + if (clock[[3L]] >= budget$wall_deadline || cpu >= budget$cpu_limit) return(TRUE) + budget$time_limit <- min(budget$cpu_limit, max(budget$time_limit * 2, cpu * 2)) + budget$deadline <- budget$scheduled_deadline <- min(budget$wall_deadline, + clock[[3L]] + budget$time_limit - cpu) + FALSE +} + member_completion <- function(uri, workspace, document, point, snippet_support, limit) { cursor <- member_cursor(document, point) resolved <- member_resolve_cursor(uri, workspace, document, point, cursor) diff --git a/R/member-inference.R b/R/member-inference.R index 3c757541..9bfd2e8d 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -544,9 +544,10 @@ member_infer <- function( if (!is.null(budget$deadline) && (is.null(budget$next_time_check) || budget$remaining <= budget$next_time_check)) { budget$next_time_check <- budget$remaining - 128L - timed_out <- proc.time()[[3L]] > budget$deadline + timed_out <- member_budget_expired(budget, proc.time()) } - if (isTRUE(budget$exhausted) || depth > 64L || budget$remaining < 0L || timed_out) { + depth_limit <- if (is.null(budget$depth_limit)) 64L else budget$depth_limit + if (isTRUE(budget$exhausted) || depth > depth_limit || budget$remaining < 0L || timed_out) { budget$exhausted <- TRUE if (timed_out) budget$timed_out <- TRUE return(member_value(reason = "budget")) diff --git a/R/member-s4.R b/R/member-s4.R index 2cddf2e7..a324648a 100644 --- a/R/member-s4.R +++ b/R/member-s4.R @@ -152,8 +152,10 @@ member_s4_descriptor <- function(name, index, bindings, package = NULL) { member_s4_shape <- function(name, index, bindings, package = NULL, trail = character(), budget = NULL) { if (!is.null(budget)) { budget$remaining <- budget$remaining - 1L - if (budget$remaining < 0L || (!is.null(budget$deadline) && proc.time()[[3L]] > budget$deadline)) { + timed_out <- !is.null(budget$deadline) && member_budget_expired(budget, proc.time()) + if (budget$remaining < 0L || timed_out) { budget$exhausted <- TRUE + if (timed_out) budget$timed_out <- TRUE return(member_value(reason = "budget")) } } diff --git a/README.md b/README.md index dc520f8d..d34cde05 100644 --- a/README.md +++ b/README.md @@ -314,8 +314,12 @@ completion and provider information remain available on derived objects. Set `options(languageserver.package_cache_dir = "/path/to/cache")` or the `R_LANGSVR_PACKAGE_CACHE_DIR` environment variable to choose another cache root; set `options(languageserver.package_cache_dir = FALSE)` to disable disk caching. -These options are also passed to metadata workers. Timed-out member requests -retry once with a larger allowance, capped at one second for the whole request. +These options are also passed to metadata workers. Cold member analysis starts +with a 250 ms allowance and extends the same traversal as needed, up to two +seconds of CPU time and five seconds elapsed. This allows for CPU contention +without restarting analysis. Node and depth bounds remain in place. Completed +receivers, including uncertain results, are reused across completion, signature +help and hover until the document or its package metadata changes. Automatic indexing recognizes a package by its `DESCRIPTION` with a `Package` field and its `R/` directory. Package indexing runs in the background and diff --git a/tests/testthat/test-member-analysis.R b/tests/testthat/test-member-analysis.R index 73497623..e76e5231 100644 --- a/tests/testthat/test-member-analysis.R +++ b/tests/testthat/test-member-analysis.R @@ -76,7 +76,7 @@ test_that("Lazy lexical locals evaluate only dependencies and respect alias hist expect_lt(20000L - resolved$budget$remaining, 20L) expect_false(resolved$budget$exhausted) deep <- member_value(type = "list", fields = list(a = member_literal(1))) - for (i in seq_len(100L)) deep <- member_local_binding(quote(x), list(x = deep)) + for (i in seq_len(256L)) deep <- member_local_binding(quote(x), list(x = deep)) budget <- member_request_budget() expect_identical(member_local_value(deep, member_generic_index(""), budget)$reason, "budget") expect_true(budget$exhausted) @@ -217,8 +217,20 @@ test_that("Recursive arguments cache only a proven native class surface", { budget$transient <- TRUE value <- member_value(type = "Frame") expect_true(member_receiver_cacheable(value, index, budget)) + possible <- member_value(reason = "possible_result", possible_returns = list(value)) + expect_true(member_receiver_cacheable(possible, index, budget)) value$fields <- list(partial = member_value(reason = "recursion")) expect_false(member_receiver_cacheable(value, index, budget)) + possible$possible_returns <- list(value) + expect_false(member_receiver_cacheable(possible, index, budget)) + cached <- member_receiver_cache_value(possible, index, budget) + expect_null(cached$type) + expect_identical(cached$reason, "possible_result") + expect_identical(cached$possible_returns[[1L]]$type, "Frame") + expect_null(cached$possible_returns[[1L]]$fields) + value$r6_class <- list(name = "Mutable") + possible$possible_returns <- list(value) + expect_null(member_receiver_cache_value(possible, index, budget)) budget$exhausted <- TRUE expect_false(member_receiver_cacheable(member_value(type = "Frame"), index, budget)) expect_false(member_receiver_cacheable(member_value(reason = "recursion"), index, budget)) diff --git a/tests/testthat/test-member-completion.R b/tests/testthat/test-member-completion.R index 0312190b..bdb9f4d1 100644 --- a/tests/testthat/test-member-completion.R +++ b/tests/testthat/test-member-completion.R @@ -42,7 +42,10 @@ test_that("The initial inference allowance distinguishes production from test ov list(value = value, budget = budget) } withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) - expect_true(resolve()$budget$exhausted) + result <- resolve() + expect_false(result$budget$exhausted) + expect_gt(result$budget$time_limit, 0.25) + expect_length(result$value$fields$alpha$elements, 256L) withr::local_envvar(c(TESTTHAT = "true")) result <- resolve() expect_false(result$budget$exhausted) diff --git a/tests/testthat/test-member-reuse-budget.R b/tests/testthat/test-member-reuse-budget.R index 561dc70e..bc2b5004 100644 --- a/tests/testthat/test-member-reuse-budget.R +++ b/tests/testthat/test-member-reuse-budget.R @@ -31,74 +31,139 @@ test_that("Member catalogs retain identities for reuse by package workers", { expect_identical(metadata$catalog("cachefixture")$identity, index$identity) }) -test_that("Timed-out member receivers retry with more time and cache successful results", { - metadata <- MemberMetadataCache$new(1024^2) - workspace <- list(member_metadata = metadata) - content <- c("x <- list(alpha = 1)", "x$") - document <- Document$new("file:///adaptive-members.R", language = "r", version = 1L, content = content) - document$parse_data <- parse_document(document$uri, content) - point <- list(row = 1L, col = 2L) - limits <- numeric() +test_that("Cold inference extends in place while accounting for CPU contention", { + withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) + timing <- new.env(parent = emptyenv()) + timing$calls <- 0L + clock <- function() { + timing$calls <- timing$calls + 1L + c((timing$calls - 1L) * 0.18, 0, (timing$calls - 1L) * 0.35) + } + infer <- member_infer + environment(infer) <- list2env(list(proc.time = clock), parent = environment(infer)) + assign("member_infer", infer, environment(infer)) budget_factory <- member_request_budget - infer <- member_cursor_value - testthat::local_mocked_bindings( - member_request_budget = function() { - budget <- budget_factory() - budget$time_limit <- 0.25 - budget - }, - member_cursor_value = function(parsed, sentinel, index, bindings, budget, ...) { - limits <<- c(limits, budget$time_limit) - if (budget$time_limit < 0.5) { - budget$exhausted <- budget$timed_out <- TRUE - return(member_value(reason = "budget")) - } - infer(parsed, sentinel, index, bindings, budget, ...) - }, .package = "languageserver") - resolve <- function() member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) - expect_identical(names(resolve()$value$fields), "alpha") - expect_identical(limits, c(0.25, 0.5)) - expect_identical(names(resolve()$value$fields), "alpha") - expect_length(limits, 2L) - content[[1L]] <- "x <- list(beta = 1)" - document$set_content(2L, content) - document$parse_data <- parse_document(document$uri, content) - expect_identical(names(resolve()$value$fields), "beta") - expect_identical(tail(limits, 1L), 0.5) + environment(budget_factory) <- list2env(list(proc.time = clock), parent = environment(budget_factory)) + expr <- as.call(c(list(as.name("list")), rep(list(1L), 1024L))) + budget <- budget_factory() + result <- infer(expr, member_generic_index(""), budget = budget) + expect_false(budget$exhausted) + expect_identical(result$type, "list") + expect_true(result$open) + expect_gt((timing$calls - 1L) * 0.35, 1) + expect_gt(budget$time_limit, 0.25) + expect_identical(budget$remaining, 20000L - 1025L) +}) + +test_that("Adaptive inference still stops at CPU and elapsed limits", { + withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) + for (clock_step in list(c(0.4, 0, 0.4), c(0.01, 0, 1.1))) { + timing <- new.env(parent = emptyenv()) + timing$calls <- 0L + clock <- function() { + timing$calls <- timing$calls + 1L + clock_step * (timing$calls - 1L) + } + infer <- member_infer + environment(infer) <- list2env(list(proc.time = clock), parent = environment(infer)) + assign("member_infer", infer, environment(infer)) + budget_factory <- member_request_budget + environment(budget_factory) <- list2env(list(proc.time = clock), parent = environment(budget_factory)) + budget <- budget_factory() + expr <- as.call(c(list(as.name("list")), rep(list(1L), 1024L))) + infer(expr, member_generic_index(""), budget = budget) + expect_true(budget$exhausted) + expect_true(budget$timed_out) + expect_gt(budget$remaining, 0L) + expect_lte(budget$deadline, budget$wall_deadline) + } +}) + +test_that("S4 inheritance uses the same adaptive allowance and honors explicit deadlines", { + withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) + timing <- new.env(parent = emptyenv()) + timing$calls <- 0L + clock <- function() { + timing$calls <- timing$calls + 1L + c(timing$calls * 0.05, 0, timing$calls * 0.3) + } + shape <- member_s4_shape + environment(shape) <- list2env(list(proc.time = clock), parent = environment(shape)) + assign("member_s4_shape", shape, environment(shape)) + budget_factory <- member_request_budget + environment(budget_factory) <- list2env(list(proc.time = clock), parent = environment(budget_factory)) index <- member_generic_index("") - metadata$set("changed", member_index_freeze(index)) - expect_identical(names(resolve()$value$fields), "beta") - expect_identical(tail(limits, 2L), c(0.25, 0.5)) + index$s4_classes$Leaf <- list(complete = TRUE, slots = list(value = "numeric")) + index$s4_classes$Branch <- list(complete = TRUE, contains = "Leaf", slots = list(label = "character")) + budget <- budget_factory() + result <- shape("Branch", index, list(), budget = budget) + expect_identical(result$slot_types, list(value = "numeric", label = "character")) + expect_false(budget$exhausted) + expect_gt(budget$time_limit, 0.25) + budget$deadline <- -1 + expect_identical(shape("Branch", index, list(), budget = budget)$reason, "budget") + expect_true(budget$timed_out) }) -test_that("Adaptive retries share the original node allowance", { +test_that("Completed uncertain receivers are reused across providers and invalidated", { + index <- member_generic_index("step <- function(label = NULL) self") + index$package <- "chainfixture" + index$exports <- "seed" + index$members <- list(box = c(step = "step")) + index$roots$seed <- member_value(reason = "open_dispatch", possible_returns = list( + member_value(type = "box", member_package = "chainfixture"))) metadata <- MemberMetadataCache$new(1024^2) - content <- c("x <- list(alpha = TRUE)", "x$") - document <- Document$new("file:///adaptive-nodes.R", language = "r", version = 1L, content = content) - document$parse_data <- parse_document(document$uri, content) - budget_factory <- member_request_budget + metadata$set("chainfixture", member_index_freeze(index)) + workspace <- list(member_metadata = metadata) + content <- c("library(chainfixture)", "object <- seed", + rep("object <- object$step()", 18L), "object$step()") + document <- Document$new("file:///uncertain-chain.R", language = "r", version = 1L, content = content) + update <- function(version) { + document$set_content(version, content) + data <- parse_document(document$uri, content) + data$version <- version + document$update_parse_data(data) + } + update(1L) calls <- 0L - allowances <- integer() - testthat::local_mocked_bindings( - member_request_budget = function() { - budget <- budget_factory() - budget$time_limit <- 0.25 - budget$remaining <- 100L - budget - }, - member_cursor_value = function(parsed, sentinel, index, bindings, budget, ...) { - calls <<- calls + 1L - allowances <<- c(allowances, budget$remaining) - if (calls == 1L) { - budget$remaining <- 7L - budget$exhausted <- budget$timed_out <- TRUE - member_value(reason = "budget") - } else { - member_value(type = "list", fields = list(alpha = member_literal(TRUE))) - } - }, .package = "languageserver") - point <- list(row = 1L, col = 2L) - result <- member_resolve_cursor(document$uri, list(member_metadata = metadata), document, point, member_cursor(document, point)) - expect_identical(allowances, c(100L, 7L)) - expect_identical(result$value$type, "list") + infer <- member_cursor_value + testthat::local_mocked_bindings(member_cursor_value = function(...) { + calls <<- calls + 1L + infer(...) + }, .package = "languageserver") + row <- length(content) - 1L + resolve <- function() { + member_resolve_cursor(document$uri, workspace, document, + list(row = row, col = 7L), member_cursor(document, list(row = row, col = 7L))) + } + result <- resolve() + expect_false(result$budget$exhausted) + expect_null(result$value$type) + expect_length(result$value$possible_returns, 1L) + expect_identical(document$member_receivers$size(), 1L) + items <- member_completion(document$uri, workspace, document, list(row = row, col = 7L), TRUE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), "step") + expect_match(items[[1L]]$detail, "[possible receiver]", fixed = TRUE) + signature <- signature_reply(1L, document$uri, workspace, document, list(row = row, col = 12L))$result + expect_identical(signature$signatures[[1L]]$label, "step(label = NULL)") + hover <- hover_reply(1L, document$uri, workspace, document, list(row = row, col = 9L))$result + expect_match(paste(hover$contents, collapse = "\n"), "Receiver type is uncertain", fixed = TRUE) + expect_identical(calls, 1L) + content[[2L]] <- "object <- list(other = TRUE)" + update(2L) + expect_length(resolve()$value$possible_returns, 0L) + expect_identical(calls, 2L) + content[[2L]] <- "object <- seed" + update(3L) + expect_length(resolve()$value$possible_returns, 1L) + index$roots$seed <- member_value(type = "list", fields = list(other = member_literal(TRUE))) + metadata$set("chainfixture", member_index_freeze(index)) + expect_length(resolve()$value$possible_returns, 0L) + expect_identical(calls, 4L) + budget <- member_request_budget() + budget$transient <- TRUE + expect_false(member_receiver_cacheable(result$value, result$index, budget)) + budget$transient <- FALSE + budget$exhausted <- TRUE + expect_false(member_receiver_cacheable(result$value, result$index, budget)) }) From 3db132ef674e3261c69bdc3367bb698999dbc436 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 09:38:41 +0800 Subject: [PATCH 08/12] Reuse member binding summaries across edits and cursor positions --- NEWS.md | 4 + R/document.R | 1 + R/member-analysis.R | 46 ++++++ R/member-completion.R | 40 +++-- R/member-inference.R | 1 + README.md | 7 +- tests/testthat/test-member-binding-cache.R | 173 +++++++++++++++++++++ 7 files changed, 261 insertions(+), 11 deletions(-) create mode 100644 tests/testthat/test-member-binding-cache.R diff --git a/NEWS.md b/NEWS.md index bab74167..a0b61f79 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,10 @@ Share these possible receivers with signature help and hover when the member implementation is unambiguous, and display an uncertainty note. Preserve possible results through member calls and subsequent assignments and aliases. + Reuse completed binding summaries across member-name and argument edits, + following-code changes and different cursor positions. Validate unchanged + preceding source and package attachment context without retaining source + closures or mutable object identities across edits. - Persist package member models, startup datasets, S3 catalogs, documentation summaries and rendered help in a shared bounded cache. Reuse unchanged models diff --git a/R/document.R b/R/document.R index 9da1b1e8..703e84f2 100644 --- a/R/document.R +++ b/R/document.R @@ -22,6 +22,7 @@ Document <- R6::R6Class( requested_packages = NULL, member_refresh = FALSE, member_receivers = NULL, + member_binding_cache = NULL, s3_calls = NULL, s3_identity = NULL, member_revision = NULL, diff --git a/R/member-analysis.R b/R/member-analysis.R index a97e8f6d..ec62c8a9 100644 --- a/R/member-analysis.R +++ b/R/member-analysis.R @@ -45,6 +45,52 @@ member_history_position <- function(history, at) { hi } +# Incremental source fingerprints are prepared with the parse, not rebuilt by +# providers. Each source segment is hashed once. Invalid virtual source ranges +# disable reuse rather than making recovery fail. +member_source_prefix <- function(content, start, end, prefix) { + if (is.null(prefix) || length(end) != 2L || anyNA(end) || !member_before(start, end) || + end[[1L]] < 0L || end[[1L]] >= length(content) || end[[2L]] < 0L || + is.na(content[[end[[1L]] + 1L]]) || + end[[2L]] > nchar(content[[end[[1L]] + 1L]])) return(NULL) + lines <- content[seq.int(start[[1L]] + 1L, end[[1L]] + 1L)] + if (anyNA(lines)) return(NULL) + lines[[length(lines)]] <- substr(lines[[length(lines)]], 1L, end[[2L]]) + lines[[1L]] <- substring(lines[[1L]], start[[2L]] + 1L) + digest::digest(list(prefix, start, end, lines), algo = "xxhash64") +} + +member_document_cache_revision <- function(document, metadata) { + if (is.null(document$member_binding_cache)) { + document$member_binding_cache <- ByteLruCache$new(4 * 1024^2, max_entries = 128L) + } + revision <- if (is.null(metadata)) 0L else if (is.function(metadata$revision)) metadata$revision() else NULL + identity <- list(metadata = if (is.function(metadata$identity)) metadata$identity() else metadata, + revision = revision) + if (!identical(document$member_revision, identity)) { + document$member_receivers$clear() + document$member_binding_cache$clear() + document$member_revision <- identity + } + revision +} + +# Cross-edit summaries must not capture lexical positions, source closures or +# mutable object identities. Package function keys are tied to the metadata +# revision; uncertain candidates have the exact same source/context key. +member_binding_cacheable <- function(value, depth = 0L) { + if (is.null(value)) return(TRUE) + if (depth > 8L || !is.null(value$function_expr) || !is.null(value$closure) || + !is.null(value$binding_expr) || !is.null(value$binding_env) || + !is.null(value$r6_class) || !is.null(value$r6_identity) || !is.null(value$r6_role) || + !is.null(value$s7_descriptor) || !is.null(value$s7_generator) || !is.null(value$s4_generator) || + (!is.null(value$function_key) && is.null(value$metadata)) || + (isTRUE(value$known_literal) && (!is.atomic(value$literal) || is.object(value$literal)))) return(FALSE) + children <- c(value$fields, value$slots, value$elements, value$possible_returns, + value[c("receiver_value", "element_shape", "result_shape", "r6_private", "r6_super", "r6_self")]) + all(vapply(children, member_binding_cacheable, logical(1L), depth + 1L)) +} + # Lazy local values keep the lexical state from before the assignment. The # memo belongs to this recovered scope, never to a package-wide summary. member_local_binding <- function(expr, bindings, referenced = member_syntax_names(expr), lookup = NULL) { diff --git a/R/member-completion.R b/R/member-completion.R index 0dc4fbf1..b7fed1e6 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -102,8 +102,14 @@ member_document_index <- function(content, parsed = NULL, syntax = NULL) { class_scope <- FALSE symbol_scope <- FALSE parts <- if (complete) member_function_parts(if (is.null(syntax)) utils::getParseData(parsed) else syntax) else NULL + prefix <- "" + previous <- c(0L, 0L) for (i in seq_along(items)) { item <- items[[i]] + prefix <- member_source_prefix(content, previous, item$end, prefix) + previous <- item$end + item$cache_prefix <- prefix + items[[i]] <- item expr <- item$expr syntax_names <- member_syntax_names(expr) if (!is.null(parts) && any(syntax_names %in% c("function", "{"))) { @@ -141,7 +147,8 @@ member_document_index <- function(content, parsed = NULL, syntax = NULL) { } if (!is.null(name) && nzchar(name)) { history <- get0(name, bindings, inherits = FALSE, ifnotfound = list()) - history[[length(history) + 1L]] <- list(expr = rhs, start = item$start, end = item$end) + history[[length(history) + 1L]] <- list(expr = rhs, start = item$start, end = item$end, + cache_prefix = prefix) assign(name, history, bindings) } } @@ -152,7 +159,7 @@ member_document_index <- function(content, parsed = NULL, syntax = NULL) { history <- get0(name, bindings, inherits = FALSE, ifnotfound = list()) history[[length(history) + 1L]] <- list( expr = quote(.__unknown_branch_write__), - start = item$start, end = item$end + start = item$start, end = item$end, cache_prefix = prefix ) assign(name, history, bindings) } @@ -360,6 +367,7 @@ member_recover_context <- function(document, content, point, cursor, start, colu member_context_index <- function(workspace, uri, document, at, parsed = NULL, referenced = member_syntax_names(parsed)) { metadata <- if (!is.null(workspace$member_metadata)) workspace$member_metadata else NULL + revision <- member_document_cache_revision(document, metadata) # Choose the extractor associated with roots actually referenced here. The # core does not recognize package names, class names, or wrapper conventions. # Follow a bounded set of referenced assignments (q may have a package @@ -403,6 +411,7 @@ member_context_index <- function(workspace, uri, document, at, parsed = NULL, } index$document_bindings <- document$parse_data$member_data$bindings index$document_cache <- new.env(parent = emptyenv()) + index$document_binding_cache <- if (!is.null(revision)) document$member_binding_cache else NULL index$methods_attached <- TRUE index$attached_roots <- list() index$attached_s4 <- list() @@ -449,8 +458,10 @@ member_context_index <- function(workspace, uri, document, at, parsed = NULL, index$attached_s4[names(package_index$s4_classes)] <- package_index$s4_classes } } + imports <- character() for (item in data$imports) { if (!member_before(item$end, at)) next + imports <- c(imports, if (is.null(item$cache_prefix)) paste(item$start, item$end, collapse = ":") else item$cache_prefix) expr <- item$expr if (length(expr) < 2L) next if (member_head(expr, "library") || member_head(expr, "require")) { @@ -479,6 +490,7 @@ member_context_index <- function(workspace, uri, document, at, parsed = NULL, if (identical(package, "S7")) index$s7_attached <- TRUE } } + index$document_context_key <- digest::digest(list(index$package, workspace$startup_packages, imports), algo = "xxhash64") index } @@ -504,8 +516,19 @@ member_resolve_document <- function(name, index, bindings, budget, depth, trail) # A source definition in a request's top-level context has stable lexical # inputs. Locals/actual arguments use their own lazy binding memos instead. memo <- !is.null(index$document_cache) && !length(setdiff(names(bindings), ".__member_position__")) - memo_key <- paste(id, paste(at, collapse = ":"), sep = ":") + memo_key <- paste(index$package, index$document_context_key, id, paste(at, collapse = ":"), sep = ":") if (memo && exists(memo_key, index$document_cache, inherits = FALSE)) return(index$document_cache[[memo_key]]) + cache <- index$document_binding_cache + persistent_key <- if (memo && !is.null(cache) && !is.null(item$cache_prefix) && + !member_head(item$expr, "function")) { + paste(index$package, index$document_context_key, id, item$cache_prefix, sep = ":") + } + cached <- if (!is.null(persistent_key)) cache$get(persistent_key) else NULL + if (!is.null(cached)) { + value <- unserialize(cached) + index$document_cache[[memo_key]] <- value + return(value) + } env <- bindings if (!member_head(item$expr, "function")) env$.__member_position__ <- item$start expr <- item$expr @@ -521,6 +544,9 @@ member_resolve_document <- function(name, index, bindings, budget, depth, trail) cached <- if (memo) member_receiver_cache_value(value, index, budget) else NULL if (!is.null(cached)) { index$document_cache[[memo_key]] <- cached + if (!is.null(persistent_key) && member_binding_cacheable(cached)) { + cache$set(persistent_key, serialize(cached, NULL)) + } } value } @@ -863,13 +889,7 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name budget <- member_request_budget() metadata <- workspace$member_metadata cache <- document$member_receivers - revision <- if (is.null(metadata)) 0L else if (is.function(metadata$revision)) metadata$revision() else NULL - identity <- list(metadata = if (is.function(metadata$identity)) metadata$identity() else metadata, - revision = revision) - if (!identical(document$member_revision, identity)) { - cache$clear() - document$member_revision <- identity - } + revision <- member_document_cache_revision(document, metadata) # The receiver does not depend on the member prefix or the call arguments # after it. Edits and accepted parses clear this document-local cache. key <- paste(point$row, cursor$start, cursor$end, cursor$operator_row, diff --git a/R/member-inference.R b/R/member-inference.R index 9bfd2e8d..b24740a3 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -88,6 +88,7 @@ member_package_context <- function(index, package) { if (is.null(owner)) return(NULL) context <- list2env(as.list(owner), parent = emptyenv()) for (name in c("namespace_indices", "namespace_metadata", "document_bindings", "document_s4", + "document_binding_cache", "document_context_key", "document_cache", "attached_roots", "attached_s4", "methods_attached")) context[[name]] <- index[[name]] context } diff --git a/README.md b/README.md index d34cde05..2b29ddfa 100644 --- a/README.md +++ b/README.md @@ -319,7 +319,12 @@ with a 250 ms allowance and extends the same traversal as needed, up to two seconds of CPU time and five seconds elapsed. This allows for CPU contention without restarting analysis. Node and depth bounds remain in place. Completed receivers, including uncertain results, are reused across completion, signature -help and hover until the document or its package metadata changes. +help and hover. Completed binding summaries also survive edits to member names, +call arguments and following code, and can serve requests at different cursor +positions. Source-prefix fingerprints are prepared by the parser; preceding +code, attachment-context or package-metadata changes invalidate those summaries. +They remain in a bounded in-memory cache for the current document. Source +closures and mutable object identities are excluded from reuse across edits. Automatic indexing recognizes a package by its `DESCRIPTION` with a `Package` field and its `R/` directory. Package indexing runs in the background and diff --git a/tests/testthat/test-member-binding-cache.R b/tests/testthat/test-member-binding-cache.R new file mode 100644 index 00000000..5e012579 --- /dev/null +++ b/tests/testthat/test-member-binding-cache.R @@ -0,0 +1,173 @@ +binding_cache_fixture <- function(possible = TRUE) { + index <- member_generic_index("step <- function(label = NULL) self") + index$package <- "bindingfixture" + index$exports <- "seed" + index$members <- list(box = c(step = "step")) + seed <- member_value(type = "box", member_package = index$package) + index$roots$seed <- if (possible) member_value(reason = "open_dispatch", possible_returns = list(seed)) else seed + metadata <- MemberMetadataCache$new(1024^2) + metadata$set(index$package, member_index_freeze(index)) + workspace <- list(member_metadata = metadata) + content <- c("library(bindingfixture)", "object <- seed", + rep("object <- object$step()", 18L), "object$step()") + document <- Document$new("file:///binding-reuse.R", language = "r", version = 0L) + update <- function(lines) { + document$set_content(document$version + 1L, lines) + data <- parse_document(document$uri, lines) + data$version <- document$version + document$update_parse_data(data) + } + update(content) + resolve <- function(row = document$nline - 1L, col = 7L) { + point <- list(row = row, col = col) + member_resolve_cursor(document$uri, workspace, document, point, member_cursor(document, point)) + } + list(index = index, metadata = metadata, workspace = workspace, + document = document, content = content, update = update, resolve = resolve) +} + +test_that("Long binding summaries survive member and argument edits across providers", { + for (possible in c(FALSE, TRUE)) { + fixture <- binding_cache_fixture(possible) + document <- fixture$document + cold <- fixture$resolve() + expect_false(cold$budget$exhausted) + expect_gt(20000L - cold$budget$remaining, 50L) + expect_gt(document$member_binding_cache$size(), 0L) + prefix <- head(fixture$content, -1L) + for (line in c("object$s", "object$st", "object$step()", "object$step(label = 2)", + "object$step(\n label = \"edited\"\n)")) { + lines <- c(prefix, strsplit(line, "\n", fixed = TRUE)[[1L]]) + fixture$update(lines) + row <- length(prefix) + result <- fixture$resolve(row) + expect_lt(20000L - result$budget$remaining, 10L) + expect_identical(length(result$value$possible_returns), if (possible) 1L else 0L) + items <- member_completion(document$uri, fixture$workspace, document, list(row = row, col = 7L), TRUE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), "step") + if (startsWith(line, "object$step(")) { + signature <- signature_reply(1L, document$uri, fixture$workspace, document, + list(row = row, col = 12L))$result + expect_identical(signature$signatures[[1L]]$label, "step(label = NULL)") + hover <- hover_reply(1L, document$uri, fixture$workspace, document, + list(row = row, col = 9L))$result + expect_match(paste(hover$contents, collapse = "\n"), "step(label = NULL)", fixed = TRUE) + } + } + fixture$update(c(fixture$content, "unrelated <- opaque_source()", "object$step()")) + result <- fixture$resolve() + expect_lt(20000L - result$budget$remaining, 10L) + expect_identical(length(result$value$possible_returns), if (possible) 1L else 0L) + lines <- fixture$content + lines[[length(lines) - 1L]] <- 'object <- object$step(label = "new stage")' + fixture$update(lines) + result <- fixture$resolve() + expect_lt(20000L - result$budget$remaining, 20L) + expect_identical(length(result$value$possible_returns), if (possible) 1L else 0L) + fixture$update(c(prefix, "object$step(", " label = ")) + result <- fixture$resolve(length(prefix)) + expect_lt(20000L - result$budget$remaining, 10L) + signature <- signature_reply(1L, document$uri, fixture$workspace, document, + list(row = document$nline - 1L, col = 10L))$result + expect_identical(signature$signatures[[1L]]$label, "step(label = NULL)") + } +}) + +test_that("Changed source prefixes and metadata cannot reuse an old binding summary", { + fixture <- binding_cache_fixture() + fixture$resolve() + content <- fixture$content + content[[2L]] <- "object <- list(other = TRUE)" + fixture$update(content) + result <- fixture$resolve() + expect_length(result$value$possible_returns, 0L) + expect_gt(20000L - result$budget$remaining, 50L) + fixture$update(fixture$content) + expect_length(fixture$resolve()$value$possible_returns, 1L) + fixture$index$roots$seed <- member_value(type = "list", fields = list(other = member_literal(TRUE))) + fixture$metadata$set("bindingfixture", member_index_freeze(fixture$index)) + fixture$update(fixture$content) + result <- fixture$resolve() + expect_length(result$value$possible_returns, 0L) + expect_gt(20000L - result$budget$remaining, 50L) + expect_identical(fixture$document$member_binding_cache$size(), 1L) +}) + +test_that("Attachment contexts and local bindings remain independent of cached globals", { + fixture <- binding_cache_fixture() + masked <- member_generic_index("advance <- function(other = FALSE) self") + masked$package <- "maskingfixture" + masked$exports <- "seed" + masked$members <- list(other = c(step = "advance")) + masked$roots$seed <- member_value(type = "other", member_package = masked$package) + fixture$metadata$set(masked$package, member_index_freeze(masked)) + expect_length(fixture$resolve()$value$possible_returns, 1L) + fixture$update(append(fixture$content, "library(maskingfixture)", after = length(fixture$content) - 1L)) + result <- fixture$resolve() + expect_identical(result$value$type, "other") + expect_gt(20000L - result$budget$remaining, 50L) + fixture$update(c(head(fixture$content, -1L), "check <- function(object) {", " object$step()", "}")) + row <- fixture$document$nline - 2L + result <- fixture$resolve(row, 9L) + expect_length(result$value$possible_returns, 0L) + expect_null(result$value$type) + fixture$update(c(head(fixture$content, -1L), "{", " object <- list(local = TRUE)", " object$step()", "}")) + result <- fixture$resolve(fixture$document$nline - 2L, 9L) + expect_identical(names(result$value$fields), "local") +}) + +test_that("Slot and quoted member requests reuse the same unchanged binding", { + fixture <- binding_cache_fixture() + seed <- fixture$index$roots$seed$possible_returns[[1L]] + seed$slot_types <- list(step = "function") + seed$slots <- list(step = member_value(type = "function", function_key = "step", metadata = "bindingfixture")) + fixture$index$roots$seed$possible_returns <- list(seed) + fixture$metadata$set("bindingfixture", member_index_freeze(fixture$index)) + fixture$resolve() + for (line in c("object@step()", "object$`step`()")) { + fixture$update(c(head(fixture$content, -1L), line)) + row <- fixture$document$nline - 1L + col <- if (grepl("`", line, fixed = TRUE)) 10L else 9L + result <- fixture$resolve(row, col) + expect_lt(20000L - result$budget$remaining, 10L) + items <- member_completion(fixture$document$uri, fixture$workspace, fixture$document, + list(row = row, col = col), TRUE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), "step") + opening <- regexpr("(", line, fixed = TRUE)[[1L]] + signature <- signature_reply(1L, fixture$document$uri, fixture$workspace, fixture$document, + list(row = row, col = opening))$result + expect_identical(signature$signatures[[1L]]$label, "step(label = NULL)") + } +}) + +test_that("Binding reuse does not capture late-bound source closures or mutable identities", { + fixture <- binding_cache_fixture(FALSE) + content <- c("value <- list(first = TRUE)", "factory <- function() value", "factory()$step()") + fixture$update(content) + point <- list(row = 2L, col = 10L) + resolve <- function() { + member_resolve_cursor(fixture$document$uri, fixture$workspace, fixture$document, + point, member_cursor(fixture$document, point)) + } + expect_identical(names(resolve()$value$fields), "first") + fixture$update(c(content[1:2], "value <- list(second = TRUE)", "factory()$step()")) + point$row <- 3L + expect_identical(names(resolve()$value$fields), "second") + expect_false(member_binding_cacheable(member_value(function_expr = quote(function() value)))) + expect_false(member_binding_cacheable(member_value(type = "environment", r6_class = list(name = "Mutable")))) + value <- member_value(type = "environment") + value$r6_identity <- "instance" + expect_false(member_binding_cacheable(value)) + expect_false(member_binding_cacheable(member_value(type = "list", fields = list( + deferred = member_local_binding(quote(value), list(value = member_literal(1))))))) +}) + +test_that("Source fingerprints retain same-line ranges and disable invalid virtual ranges", { + before <- member_document_index(c("first <- 1; object <- list(α = first)", "object$s")) + after <- member_document_index(c("first <- 1; object <- list(α = first)", "object$step(label = 1)")) + expect_identical(before$bindings$object[[1L]]$cache_prefix, after$bindings$object[[1L]]$cache_prefix) + changed <- member_document_index(c("first <- 2; object <- list(α = first)", "object$s")) + expect_false(identical(before$bindings$object[[1L]]$cache_prefix, changed$bindings$object[[1L]]$cache_prefix)) + expect_null(member_source_prefix("x <- 1", c(0L, 0L), c(1000L, 0L), "")) + expect_null(member_source_prefix(c("x <- 1", NA_character_), c(0L, 0L), c(1L, 2L), "")) +}) From aab8a5f093ec124da886d8f0970465524b31bf6c Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 11:42:46 +0800 Subject: [PATCH 09/12] Share semantic analysis caches across providers and parse workers --- NEWS.md | 8 + R/analysis-cache.R | 50 ++++++ R/document.R | 3 +- R/hover.R | 6 +- R/member-analysis.R | 5 +- R/member-completion.R | 1 + R/navigation.R | 6 +- R/s3-dispatch.R | 96 +++++++++--- R/s3-inference.R | 8 + R/signature.R | 5 +- R/workspace.R | 1 + README.md | 9 ++ tests/testthat/test-analysis-cache.R | 221 +++++++++++++++++++++++++++ 13 files changed, 388 insertions(+), 31 deletions(-) create mode 100644 R/analysis-cache.R create mode 100644 tests/testthat/test-analysis-cache.R diff --git a/NEWS.md b/NEWS.md index a0b61f79..b1b90131 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,6 +18,14 @@ preceding source and package attachment context without retaining source closures or mutable object identities across edits. +- Share bounded semantic analysis caches across member and S3 inference, + source signature/documentation providers and package NAMESPACE parsing. + Reuse completed S3 binding summaries across edits and cursor positions while + validating peer-source contents, metadata and registration context. Exclude + exhausted and scratch-state results from reuse. Retain exact-text signature + and documentation facts across reparses, including unchanged comment blocks + in persistent parse workers. + - Persist package member models, startup datasets, S3 catalogs, documentation summaries and rendered help in a shared bounded cache. Reuse unchanged models across saves and server sessions; invalidate changes to package files, diff --git a/R/analysis-cache.R b/R/analysis-cache.R new file mode 100644 index 00000000..7a36baf5 --- /dev/null +++ b/R/analysis-cache.R @@ -0,0 +1,50 @@ +# Analysis adapters supply the semantic context and key that make a result +# reusable. Stores are allocated on demand, bounded independently by domain, +# and retain serialized values so mutable request state is never shared. +analysis_cache <- function(owner, domain, context = NULL, max_bytes = 2 * 1024^2, max_entries = 128L) { + if (is.null(owner$analysis_caches)) owner$analysis_caches <- new.env(parent = emptyenv()) + entry <- owner$analysis_caches[[domain]] + if (is.null(entry)) { + entry <- list(context = context, values = ByteLruCache$new(max_bytes, max_entries)) + } else if (!identical(entry$context, context)) { + entry$values$clear() + entry$context <- context + } + owner$analysis_caches[[domain]] <- entry + entry$values +} + +analysis_cache_get <- function(cache, key) { + if (is.null(cache) || is.null(key) || !cache$has(key)) return(list(hit = FALSE)) + list(hit = TRUE, value = unserialize(cache$get(key))) +} + +analysis_cache_set <- function(cache, key, value) { + if (!is.null(cache) && !is.null(key)) cache$set(key, serialize(value, NULL)) + invisible(value) +} + +# Exact syntax is a context-independent input. Only formals are parsed; neither +# function bodies nor defaults are evaluated. Both syntax and XML providers use +# these facts across reparses, independently of declaration position. +analysis_function_header <- function(document, text, symbol) { + cache <- analysis_cache(document, "function-headers") + key <- digest::digest(list(symbol, text), algo = "xxhash64") + found <- analysis_cache_get(cache, key) + if (found$hit) return(found$value) + fn <- str2expression(c(text, "NULL"))[[1L]] + value <- list(signature = get_signature(symbol, fn), formals = fn[[2L]]) + analysis_cache_set(cache, key, value) +} + +analysis_documentation_owner <- new.env(parent = emptyenv()) + +analysis_documentation <- function(document, comments) { + owner <- if (is.null(document)) analysis_documentation_owner else document + cache <- analysis_cache(owner, "source-documentation", context = asNamespace("roxygen2")) + key <- digest::digest(comments, algo = "xxhash64") + found <- analysis_cache_get(cache, key) + if (found$hit) return(found$value) + value <- if (length(comments)) convert_comment_to_documentation(comments) + analysis_cache_set(cache, key, value) +} diff --git a/R/document.R b/R/document.R index 703e84f2..12cf2551 100644 --- a/R/document.R +++ b/R/document.R @@ -23,6 +23,7 @@ Document <- R6::R6Class( member_refresh = FALSE, member_receivers = NULL, member_binding_cache = NULL, + analysis_caches = NULL, s3_calls = NULL, s3_identity = NULL, member_revision = NULL, @@ -548,7 +549,7 @@ parse_expr <- function(content, expr, env, srcref = attr(expr, "srcref")) { } assign( symbol, - convert_comment_to_documentation(comment), + analysis_documentation(NULL, comment), envir = env$documentation_store ) } diff --git a/R/hover.R b/R/hover.R index 1b03d69a..e01ebaf2 100644 --- a/R/hover.R +++ b/R/hover.R @@ -132,7 +132,7 @@ hover_reply <- function(id, uri, workspace, document, point) { doc_line1 <- detect_comments(document$content, def_line1 - 1) + 1 if (doc_line1 < def_line1) { comment <- document$content[doc_line1:(def_line1 - 1)] - doc <- convert_comment_to_documentation(comment) + doc <- analysis_documentation(document, comment) if (is.character(doc)) { doc_string <- doc } else if (is.list(doc)) { @@ -168,7 +168,7 @@ hover_reply <- function(id, uri, workspace, document, point) { doc_line1 <- detect_comments(document$content, func_line1 - 1) + 1 if (doc_line1 < func_line1) { comment <- document$content[doc_line1:(func_line1 - 1)] - doc <- convert_comment_to_documentation(comment) + doc <- analysis_documentation(document, comment) if (is.list(doc)) { doc_string <- doc$arguments[[token_text]] if (!is.null(doc_string)) { @@ -197,7 +197,7 @@ hover_reply <- function(id, uri, workspace, document, point) { if (doc_line1 < func_line1) { comment <- document$content[doc_line1:(func_line1 - 1)] - doc <- convert_comment_to_documentation(comment) + doc <- analysis_documentation(document, comment) if (is.list(doc)) { doc_string <- doc$arguments[[token_text]] if (!is.null(doc_string)) { diff --git a/R/member-analysis.R b/R/member-analysis.R index ec62c8a9..c08dd092 100644 --- a/R/member-analysis.R +++ b/R/member-analysis.R @@ -61,15 +61,12 @@ member_source_prefix <- function(content, start, end, prefix) { } member_document_cache_revision <- function(document, metadata) { - if (is.null(document$member_binding_cache)) { - document$member_binding_cache <- ByteLruCache$new(4 * 1024^2, max_entries = 128L) - } revision <- if (is.null(metadata)) 0L else if (is.function(metadata$revision)) metadata$revision() else NULL identity <- list(metadata = if (is.function(metadata$identity)) metadata$identity() else metadata, revision = revision) + document$member_binding_cache <- analysis_cache(document, "member-bindings", identity, max_bytes = 4 * 1024^2) if (!identical(document$member_revision, identity)) { document$member_receivers$clear() - document$member_binding_cache$clear() document$member_revision <- identity } revision diff --git a/R/member-completion.R b/R/member-completion.R index b7fed1e6..b27eb08d 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -168,6 +168,7 @@ member_document_index <- function(content, parsed = NULL, syntax = NULL) { } source_bytes <- if (complete) member_compact_source(parsed, parts) else 0 list(items = items, bindings = as.list(bindings), imports = imports, effects = effects, s4 = s4, + content_key = digest::digest(content, algo = "xxhash64"), source_bytes = source_bytes, packages = packages, class_scope = class_scope, symbol_scope = symbol_scope, s3 = s3_source_index(items)) diff --git a/R/navigation.R b/R/navigation.R index a3c536ca..02101e0d 100644 --- a/R/navigation.R +++ b/R/navigation.R @@ -133,8 +133,7 @@ navigation_signature <- function(document, parse_data, row, symbol) { closing <- syntax$function_close[[row]] text <- get_range_text(document$content, syntax$line1[[row]], syntax$col1[[row]], syntax$line2[[closing]], syntax$col2[[closing]]) - expr <- str2expression(c(text, "NULL")) - found <- get_signature(symbol, expr[[1L]]) + found <- analysis_function_header(document, text, symbol)$signature assign(key, found, envir = index$cache) found } @@ -146,7 +145,8 @@ navigation_documentation <- function(document, parse_data, line) { key <- paste0("documentation:", line) if (exists(key, envir = cache, inherits = FALSE)) return(get(key, envir = cache)) first <- detect_comments(document$content, line - 1L) + 1L - doc <- if (first < line) convert_comment_to_documentation(document$content[seq.int(first, line - 1L)]) + comments <- if (first < line) document$content[seq.int(first, line - 1L)] else character() + doc <- analysis_documentation(document, comments) assign(key, doc, envir = cache) doc } diff --git a/R/s3-dispatch.R b/R/s3-dispatch.R index 3b4d9988..204c8294 100644 --- a/R/s3-dispatch.R +++ b/R/s3-dispatch.R @@ -65,7 +65,8 @@ s3_source_view <- function(document) { if (is.null(data)) { return(NULL) } - list(index = data$s3 %s3_or% s3_source_index(data$items), items = data$items, uri = document$uri) + list(index = data$s3 %s3_or% s3_source_index(data$items), items = data$items, + uri = document$uri, content_key = data$content_key) } s3_source_value <- function(name, context) { @@ -83,6 +84,15 @@ s3_source_value <- function(name, context) { return(s3_unknown("binding_cycle")) } item <- source$items[[record$item]] + cache_key <- if (!is.null(context$binding_cache) && s3_binding_context_unchanged(context) && !is.null(item$cache_prefix) && + !is.null(context$binding_contexts[[source$uri]])) { + paste(source$uri, name, position, item$cache_prefix, context$binding_contexts[[source$uri]], sep = ":") + } + cached <- analysis_cache_get(context$binding_cache, cache_key) + if (cached$hit) { + context$memo[[key]] <- cached$value + return(cached$value) + } old_at <- context$at old_uri <- context$source_uri context$trail <- c(context$trail, key) @@ -126,6 +136,10 @@ s3_source_value <- function(name, context) { result <- get0(name, scope, inherits = FALSE) %s3_or% s3_unknown("opaque_effect") } context$memo[[key]] <- result + if (!isTRUE(context$exhausted) && s3_binding_context_unchanged(context) && + length(result$classes) && s3_binding_cacheable(result)) { + analysis_cache_set(context$binding_cache, cache_key, result) + } return(result) } NULL @@ -328,10 +342,11 @@ s3_context <- function(uri, workspace, document, at) { } } root <- s3_package_root(workspace, uri) + namespace <- list(key = "", records = list(), valid = TRUE) if (!is.null(root)) { - path <- file.path(root, "NAMESPACE") - if (file.exists(path) && file.info(path)$size > 65536L) context$registration_unknown <- TRUE - for (record in s3_namespace_source(root)) { + namespace <- s3_namespace_snapshot(root, workspace) + if (!isTRUE(namespace$valid)) context$registration_unknown <- TRUE + for (record in namespace$records) { value <- s3_get_value(record$method, context$root, context, source_only = TRUE) if (is.null(value$fn)) next key <- paste(record$generic, record$class, sep = ".") @@ -341,9 +356,37 @@ s3_context <- function(uri, workspace, document, at) { } } context$analyzer <- analyzer + context$binding_root <- as.list(context$root, all.names = TRUE) + context$binding_imports <- context$imports + context$binding_contexts <- list() + if (!isTRUE(context$incomplete) && !isTRUE(context$registration_unknown) && !isTRUE(context$exhausted) && + is.function(metadata$revision) && is.function(metadata$identity) && + all(vapply(context$sources, function(source) !is.null(source$content_key), logical(1L)))) { + context$binding_cache <- analysis_cache(document, "s3-bindings", + list(metadata = metadata$identity(), revision = metadata$revision(), namespace = namespace$key), + max_bytes = 4 * 1024^2) + source_keys <- vapply(context$sources, `[[`, "", "content_key") + source_uris <- vapply(context$sources, `[[`, "", "uri") + registrations <- unlist(lapply(context$sources, function(source) { + vapply(source$index$registrations, function(i) { + item <- source$items[[i]] + if (!identical(source$uri, uri) || member_before(item$end, at)) item$cache_prefix %s3_or% "" else "" + }, "") + }), use.names = FALSE) + for (i in seq_along(source_uris)) { + context$binding_contexts[[source_uris[[i]]]] <- digest::digest(list( + sources = source_uris[-i], content = source_keys[-i], imports = context$imports, + registrations = registrations, startup = startup_packages), algo = "xxhash64") + } + } context } +s3_binding_context_unchanged <- function(context) { + identical(context$imports, context$binding_imports) && + identical(as.list(context$root, all.names = TRUE), context$binding_root) +} + # Recover the enclosing call with its lexical scopes and following arguments. # The same path is used for complete source and bounded incomplete recovery. s3_call_location <- function(document, point, hover = FALSE, call = NULL) { @@ -507,7 +550,10 @@ resolve_s3_call <- function(uri, workspace, document, point, hover = FALSE, call return(cache$get(cache_key)) } result <- NULL - on.exit(if (!is.null(revision)) cache$set(cache_key, result), add = TRUE) + context <- NULL + on.exit(if (!is.null(revision) && !isTRUE(context$exhausted)) { + cache$set(cache_key, result) + }, add = TRUE) context <- s3_context(uri, workspace, document, c(location$point$row, location$point$col)) scoped <- s3_scoped_call(document, location, context) if (is.null(scoped)) { @@ -599,6 +645,17 @@ s3_index_summary <- function(content, uri, expressions = NULL, parse_data = NULL } else { return(NULL) } + # Older or standalone index builders may not supply member fingerprints. + # Compute the same bounded source-prefix keys before compacting bodies. + if (length(items) && any(vapply(items, function(item) is.null(item$cache_prefix), logical(1L)))) { + prefix <- "" + previous <- c(0L, 0L) + for (i in seq_along(items)) { + prefix <- member_source_prefix(content, previous, items[[i]]$end, prefix) + previous <- items[[i]]$end + items[[i]]$cache_prefix <- prefix + } + } # An enormous factory cannot be analyzed within a request. Retain its # generic descriptor/formals without duplicating its body in disk indexes. items <- lapply(items, function(item) { @@ -616,7 +673,8 @@ s3_index_summary <- function(content, uri, expressions = NULL, parse_data = NULL } item }) - list(uri = uri, items = items, index = s3_source_index(items)) + list(uri = uri, items = items, index = s3_source_index(items), + content_key = parse_data$member_data$content_key %s3_or% digest::digest(content, algo = "xxhash64")) } s3_recover_call <- function(document, location, recovered) { @@ -893,12 +951,17 @@ s3_queue_ready <- function(self, uri) { } } -s3_namespace_source <- function(root) { +s3_namespace_snapshot <- function(root, owner = NULL) { path <- file.path(root, "NAMESPACE") - if (!file.exists(path) || file.info(path)$size > 65536L) { - return(list()) - } - code <- tryCatch(parse(path, keep.source = FALSE), error = function(e) NULL) + if (!file.exists(path)) return(list(key = "", records = list(), valid = TRUE)) + if (file.info(path)$size > 65536L) return(list(key = "oversized", records = list(), valid = FALSE)) + text <- tryCatch(readLines(path, warn = FALSE), error = function(e) NULL) + if (is.null(text)) return(list(key = "unreadable", records = list(), valid = FALSE)) + key <- digest::digest(text, algo = "xxhash64") + cache <- if (!is.null(owner)) analysis_cache(owner, "namespace-declarations", max_bytes = 1024^2, max_entries = 32L) + cached <- analysis_cache_get(cache, paste(path, key, sep = ":")) + if (cached$hit) return(cached$value) + code <- tryCatch(parse(text = text, keep.source = FALSE), error = function(e) NULL) records <- list() for (expr in code) { if (!member_head(expr, "S3method") || length(expr) < 3L) next @@ -912,9 +975,12 @@ s3_namespace_source <- function(root) { class = class, method = method ) } - records + value <- list(key = key, records = records, valid = !is.null(code)) + analysis_cache_set(cache, paste(path, key, sep = ":"), value) } +s3_namespace_source <- function(root) s3_namespace_snapshot(root)$records + s3_package_root <- function(workspace, uri) { root <- if (!is.null(workspace$index) && isTRUE(workspace$index$enabled)) { workspace$index$package_root_for_uri(uri) @@ -926,9 +992,5 @@ s3_package_root <- function(workspace, uri) { s3_namespace_generation <- function(workspace, uri) { root <- s3_package_root(workspace, uri) if (is.null(root)) return("") - path <- file.path(root, "NAMESPACE") - if (!file.exists(path)) return("") - metadata <- file.info(path) - if (metadata$size > 65536L) return("oversized") - digest::digest(readLines(path, warn = FALSE), algo = "xxhash64") + s3_namespace_snapshot(root, workspace)$key } diff --git a/R/s3-inference.R b/R/s3-inference.R index c54981a9..b80c28bf 100644 --- a/R/s3-inference.R +++ b/R/s3-inference.R @@ -50,6 +50,13 @@ s3_model_classes <- list( # Class-only S3 analysis shares syntax, argument and source-index helpers with # member inference. Values are inert; document code and defaults are not run. s3_unknown <- function(reason = "unsupported") list(classes = NULL, type = NULL, reason = reason) + +s3_binding_cacheable <- function(value, depth = 0L) { + if (is.null(value) || depth > 12L || isTRUE(value$reason %in% c("budget", "binding_cycle")) || + !is.null(value$fn) || !is.null(value$closure) || !is.null(value$info) || + (isTRUE(value$known) && (!is.atomic(value$literal) || is.object(value$literal)))) return(FALSE) + all(vapply(value$fields, s3_binding_cacheable, logical(1L), depth + 1L)) +} s3_value <- function( classes, type = NULL, literal = NULL, known = FALSE, fields = NULL, fn = NULL, closure = NULL, origin = NULL, function_name = NULL, info = NULL, dimensions = NULL, @@ -138,6 +145,7 @@ s3_analyzer <- function(context, env = new.env(parent = emptyenv())) { infer <- function(expr, scope = env, depth = 0L) { context$nodes <- context$nodes + 1L if (context$nodes > 20000L || depth > 64L || proc.time()[[3L]] > context$deadline) { + context$exhausted <- TRUE return(s3_unknown("budget")) } recur <- function(x, e = scope) infer(x, e, depth + 1L) diff --git a/R/signature.R b/R/signature.R index 480fdfc4..4c4babd2 100644 --- a/R/signature.R +++ b/R/signature.R @@ -14,8 +14,7 @@ local_function_signature <- function(document, node, symbol) { col2 = as.integer(xml_attr(closing, "col2"))) # Only the formals are used by get_signature(). A large body contributes # no signature information and need not be allocated or parsed again. - expr <- str2expression(c(text, "NULL")) - get_signature(symbol, expr[[1L]]) + analysis_function_header(document, text, symbol)$signature } #' Parse a signature once for both parameter names and LSP label ranges @@ -169,7 +168,7 @@ signature_reply <- function(id, uri, workspace, document, point, client_capabili doc_line1 <- detect_comments(document$content, func_line1 - 1) + 1 if (doc_line1 < func_line1) { comment <- document$content[doc_line1:(func_line1 - 1)] - doc <- convert_comment_to_documentation(comment) + doc <- analysis_documentation(document, comment) doc_string <- NULL if (is.character(doc)) { diff --git a/R/workspace.R b/R/workspace.R index 5e50beb2..c99a14d9 100644 --- a/R/workspace.R +++ b/R/workspace.R @@ -361,6 +361,7 @@ Workspace <- R6::R6Class("Workspace", diagnostics_globals_cache = NULL, type_hierarchy_cache = NULL, member_metadata = NULL, + analysis_caches = NULL, s3_metadata = NULL, s3_revision = 0L, diff --git a/README.md b/README.md index 2b29ddfa..e7f90fc0 100644 --- a/README.md +++ b/README.md @@ -326,6 +326,15 @@ code, attachment-context or package-metadata changes invalidate those summaries. They remain in a bounded in-memory cache for the current document. Source closures and mutable object identities are excluded from reuse across edits. +Shared analysis caches also reuse completed S3 class summaries across requests +and edits, checking package metadata, attachment/registration context and exact +peer-source contents. Budget-exhausted and mutable scratch-state results are +excluded. Local signature and documentation facts use their exact source text +as keys and survive reparses; persistent parse workers reuse unchanged comment +blocks. Package NAMESPACE declarations are read for current content and reuse +their parsed facts when that content is unchanged. These bounded caches are +allocated on demand and store serialized results for independent requests. + Automatic indexing recognizes a package by its `DESCRIPTION` with a `Package` field and its `R/` directory. Package indexing runs in the background and prioritizes package sources. A workspace containing standalone scripts starts diff --git a/tests/testthat/test-analysis-cache.R b/tests/testthat/test-analysis-cache.R new file mode 100644 index 00000000..6be62b22 --- /dev/null +++ b/tests/testthat/test-analysis-cache.R @@ -0,0 +1,221 @@ +analysis_s3_fixture <- local({ + state <- new.env(parent = emptyenv()) + function(content) { + if (is.null(state$catalogs)) state$catalogs <- stats::setNames(lapply(startup_packages, s3_prepare_namespace), startup_packages) + fixture <- provider_fixture(content) + fixture$workspace$s3_metadata <- S3MetadataCache$new() + for (package in names(state$catalogs)) fixture$workspace$s3_metadata$set(package, state$catalogs[[package]]) + fixture$workspace$get_documentation <- function(...) NULL + fixture + } +}) + +analysis_cache_update <- function(fixture, content) { + document <- fixture$document + document$set_content(document$version + 1L, content) + parsed <- parse_document(document$uri, content) + parsed$version <- document$version + document$update_parse_data(parsed) +} + +test_that("Analysis domains isolate contexts, bound storage and clone cached values", { + owner <- new.env(parent = emptyenv()) + first <- analysis_cache(owner, "first", "context", max_entries = 2L) + second <- analysis_cache(owner, "second", "context") + analysis_cache_set(first, "a", list(value = 1)) + analysis_cache_set(second, "a", list(value = 2)) + value <- analysis_cache_get(first, "a") + value$value$value <- 3 + expect_identical(analysis_cache_get(first, "a")$value$value, 1) + expect_identical(analysis_cache_get(second, "a")$value$value, 2) + analysis_cache_set(first, "null", NULL) + expect_true(analysis_cache_get(first, "null")$hit) + expect_null(analysis_cache_get(first, "null")$value) + analysis_cache_set(first, "new", 4) + expect_lte(first$size(), 2L) + expect_false(analysis_cache_get(first, "a")$hit) + first <- analysis_cache(owner, "first", "changed") + expect_identical(first$size(), 0L) + expect_true(analysis_cache_get(second, "a")$hit) + bounded <- analysis_cache(owner, "bounded", max_bytes = 256L) + analysis_cache_set(bounded, "large", raw(1000L)) + expect_false(analysis_cache_get(bounded, "large")$hit) +}) + +test_that("Source signatures and documentation survive reparses and retain current inputs", { + lines <- c("#' Describe a source function.", "#' @param argument The value.", + "target <- function(argument, option = 1) argument", "target(1, 2)") + fixture <- provider_fixture(lines) + document <- fixture$document + point <- list(row = 3L, col = 7L) + signature <- signature_reply(1L, fixture$uri, fixture$workspace, document, point)$result + expect_identical(signature$signatures[[1L]]$label, "target(argument, option = 1)") + expect_match(signature$signatures[[1L]]$documentation$value, "Describe a source function", fixed = TRUE) + lines[[4L]] <- "target(3, 4)" + analysis_cache_update(fixture, lines) + old_header <- analysis_function_header + old_docs <- convert_comment_to_documentation + header <- old_header + environment(header) <- list2env(list(str2expression = function(...) stop("Reparsed unchanged formals")), + parent = environment(header)) + testthat::local_mocked_bindings( + analysis_function_header = header, + convert_comment_to_documentation = function(...) stop("Reparsed unchanged documentation"), + .package = "languageserver") + signature <- signature_reply(1L, fixture$uri, fixture$workspace, document, point)$result + expect_identical(signature$signatures[[1L]]$label, "target(argument, option = 1)") + hover <- hover_reply(1L, fixture$uri, fixture$workspace, document, list(row = 3L, col = 3L))$result + expect_match(paste(hover$contents, collapse = "\n"), "Describe a source function", fixed = TRUE) + # Direct input checks do not reuse an old source signature or description. + testthat::local_mocked_bindings(analysis_function_header = old_header, convert_comment_to_documentation = old_docs, + .package = "languageserver") + lines[[1L]] <- "#' The updated description." + lines[[3L]] <- "target <- function(argument, revised = TRUE) argument" + analysis_cache_update(fixture, lines) + signature <- signature_reply(1L, fixture$uri, fixture$workspace, document, point)$result + expect_identical(signature$signatures[[1L]]$label, "target(argument, revised = TRUE)") + expect_match(signature$signatures[[1L]]$documentation$value, "updated description", fixed = TRUE) +}) + +test_that("Parse workers reuse unchanged documentation across function and call edits", { + content <- c("#' Worker cache documentation fixture.", "#' @param value The input.", + "target <- function(value, extra = 1) value", "target(1)") + first <- parse_document("file:///worker-documentation.R", content) + expect_match(first$documentation$target$description, "Worker cache", fixed = TRUE) + content[[3L]] <- "target <- function(value, extra = 2) value" + content[[4L]] <- "target(2)" + testthat::local_mocked_bindings(convert_comment_to_documentation = function(...) { + stop("Repeated worker documentation conversion") + }, .package = "languageserver") + second <- parse_document("file:///worker-documentation.R", content) + expect_identical(second$documentation$target, first$documentation$target) +}) + +test_that("S3 binding inference reuses complete summaries across edits and cursor positions", { + content <- c("factory <- function(input) data.frame(value = input)", "item <- factory(1)", + rep("item <- factory(item)", 8L), "print(item, digits = 1)") + fixture <- analysis_s3_fixture(content) + resolve <- function() { + context <- s3_context(fixture$uri, fixture$workspace, fixture$document, + c(fixture$document$nline - 1L, 0L)) + value <- s3_source_value("item", context) + list(value = value, nodes = context$nodes) + } + cold <- resolve() + expect_identical(cold$value$classes, "data.frame") + expect_gt(cold$nodes, 20L) + content[[length(content)]] <- "print(item, digits = 2)" + analysis_cache_update(fixture, content) + warm <- resolve() + expect_identical(warm$value, cold$value) + expect_identical(warm$nodes, 0L) + analysis_cache_update(fixture, c(content, "print(item, digits = 3)")) + expect_lte(resolve()$nodes, 3L) + content[[1L]] <- "factory <- function(input) input" + analysis_cache_update(fixture, content) + expect_identical(resolve()$value$classes, .class2(1)) +}) + +test_that("S3 reuse validates peer contents and metadata identity", { + fixture <- analysis_s3_fixture(c("item <- factory(1)", "print(item)")) + peer <- Document$new("file:///peer-source.R", language = "r", version = 1L, + content = "factory <- function(input) data.frame(value = input)") + data <- parse_document(peer$uri, peer$content) + data$version <- peer$version + peer$update_parse_data(data) + fixture$workspace$documents$set(peer$uri, peer) + resolve <- function() { + context <- s3_context(fixture$uri, fixture$workspace, fixture$document, c(1L, 0L)) + list(value = s3_source_value("item", context), context = context) + } + expect_identical(resolve()$value$classes, "data.frame") + expect_identical(resolve()$context$nodes, 0L) + peer$set_content(1L, "factory <- function(input) input") + data <- parse_document(peer$uri, peer$content) + data$version <- 1L + peer$update_parse_data(data) + expect_identical(resolve()$value$classes, .class2(1)) + old <- fixture$workspace$s3_metadata + fixture$workspace$s3_metadata <- S3MetadataCache$new() + for (package in old$keys()) fixture$workspace$s3_metadata$set(package, old$get(package)) + expect_gt(resolve()$context$nodes, 0L) +}) + +test_that("Indexed source summaries participate in S3 reuse without version-only validation", { + fixture <- analysis_s3_fixture(c("item <- factory(1)", "print(item)")) + peer_uri <- "file:///indexed-source.R" + summaries <- collections::dict() + fixture$workspace$index <- list(enabled = TRUE, package_root_for_uri = function(...) NULL, + source_closure = function(...) c(fixture$uri, peer_uri), summaries = summaries) + update <- function(text) { + parsed <- parse(text = text, keep.source = TRUE) + summaries$set(peer_uri, list(s3 = s3_index_summary(text, peer_uri, expressions = parsed))) + } + update("factory <- function(input) data.frame(value = input)") + resolve <- function() { + context <- s3_context(fixture$uri, fixture$workspace, fixture$document, c(1L, 0L)) + value <- s3_source_value("item", context) + list(value = value, context = context) + } + expect_identical(resolve()$value$classes, "data.frame") + expect_identical(resolve()$context$nodes, 0L) + update("factory <- function(input) input") + expect_identical(resolve()$value$classes, .class2(1)) +}) + +test_that("Partial S3 results and scratch-state effects are excluded from reuse", { + expect_false(s3_binding_cacheable(s3_value("data.frame", fields = list(partial = s3_unknown("budget"))))) + expect_false(s3_binding_cacheable(s3_value(NULL, fn = quote(function() value), closure = new.env()))) + fixture <- analysis_s3_fixture(c("item <- {scratch <- 1; data.frame(value = scratch)}", "print(item)")) + resolve <- function() { + context <- s3_context(fixture$uri, fixture$workspace, fixture$document, c(1L, 0L)) + value <- s3_source_value("item", context) + list(context = context, value = value) + } + expect_identical(resolve()$value$classes, "data.frame") + expect_gt(resolve()$context$nodes, 0L) + context <- s3_context(fixture$uri, fixture$workspace, fixture$document, c(1L, 0L)) + context$deadline <- -1 + s3_source_value("item", context) + expect_true(context$exhausted) + expect_identical(context$binding_cache$size(), 0L) +}) + +test_that("An exhausted S3 request cannot pin an incomplete result", { + fixture <- analysis_s3_fixture(c("render <- function(x, ...) UseMethod('render')", + "render.numeric <- function(x, digits = 1, ...) NULL", "render(1, digits = 2)")) + build_context <- s3_context + testthat::local_mocked_bindings(s3_context = function(...) { + context <- build_context(...) + context$deadline <- -1 + context + }, .package = "languageserver") + resolve <- function() resolve_s3_call(fixture$uri, fixture$workspace, fixture$document, list(row = 2L, col = 20L)) + expect_null(resolve()) + expect_identical(fixture$document$s3_calls$size(), 0L) + testthat::local_mocked_bindings(s3_context = build_context, .package = "languageserver") + expect_identical(resolve()$method$name, "render.numeric") +}) + +test_that("NAMESPACE declarations reuse parsed facts while checking exact current contents", { + root <- tempfile() + dir.create(root) + withr::defer(unlink(root, recursive = TRUE)) + path <- file.path(root, "NAMESPACE") + writeLines("S3method(render, first)", path) + owner <- new.env(parent = emptyenv()) + first <- s3_namespace_snapshot(root, owner) + expect_identical(first$records[[1L]]$class, "first") + snapshot <- s3_namespace_snapshot + environment(snapshot) <- list2env(list(parse = function(...) stop("Reparsed NAMESPACE")), + parent = environment(snapshot)) + expect_identical(snapshot(root, owner), first) + stamp <- file.info(path)$mtime + writeLines("S3method(render, other)", path) + Sys.setFileTime(path, stamp) + second <- s3_namespace_snapshot(root, owner) + expect_identical(second$records[[1L]]$class, "other") + expect_false(identical(first$key, second$key)) + writeLines("S3method(", path) + expect_false(s3_namespace_snapshot(root, owner)$valid) +}) From da70d5fe803f5eb275153462ee0d33ac071fd881 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 15:09:32 +0800 Subject: [PATCH 10/12] Harden cache isolation, invalidation and server compatibility --- R/analysis-cache.R | 41 ++++- R/member-analysis.R | 11 +- R/member-completion.R | 8 +- R/member-metadata.R | 3 +- R/namespace.R | 30 ++-- R/package-cache.R | 177 ++++++++++++++++--- R/s3-metadata.R | 9 +- R/utils.R | 16 +- R/workspace.R | 7 +- R/zzz.R | 7 +- README.md | 9 + tests/testthat/test-analysis-cache.R | 38 ++++ tests/testthat/test-member-analysis.R | 26 +++ tests/testthat/test-package-metadata-cache.R | 166 ++++++++++++++++- 14 files changed, 483 insertions(+), 65 deletions(-) diff --git a/R/analysis-cache.R b/R/analysis-cache.R index 7a36baf5..9ad4a54d 100644 --- a/R/analysis-cache.R +++ b/R/analysis-cache.R @@ -1,14 +1,19 @@ # Analysis adapters supply the semantic context and key that make a result # reusable. Stores are allocated on demand, bounded independently by domain, # and retain serialized values so mutable request state is never shared. +analysis_cache_format <- 2L + analysis_cache <- function(owner, domain, context = NULL, max_bytes = 2 * 1024^2, max_entries = 128L) { if (is.null(owner$analysis_caches)) owner$analysis_caches <- new.env(parent = emptyenv()) entry <- owner$analysis_caches[[domain]] - if (is.null(entry)) { - entry <- list(context = context, values = ByteLruCache$new(max_bytes, max_entries)) - } else if (!identical(entry$context, context)) { - entry$values$clear() - entry$context <- context + limits <- list(bytes = max(as.numeric(max_bytes), 0), entries = max(as.integer(max_entries), 1L)) + runtime <- list(namespace = asNamespace("languageserver"), format = analysis_cache_format) + if (is.null(entry) || !identical(entry$context, context) || !identical(entry$limits, limits) || + !identical(entry$runtime, runtime)) { + # Keep old handles isolated: an in-flight computation may still write + # its result after a newer context has been installed. + entry <- list(context = context, limits = limits, runtime = runtime, + values = ByteLruCache$new(limits$bytes, limits$entries)) } owner$analysis_caches[[domain]] <- entry entry$values @@ -16,11 +21,29 @@ analysis_cache <- function(owner, domain, context = NULL, max_bytes = 2 * 1024^2 analysis_cache_get <- function(cache, key) { if (is.null(cache) || is.null(key) || !cache$has(key)) return(list(hit = FALSE)) - list(hit = TRUE, value = unserialize(cache$get(key))) + tryCatch({ + record <- cache$get(key) + if (!is.list(record) || is.object(record) || !identical(record$format, analysis_cache_format) || !is.raw(record$payload) || + !identical(record$checksum, digest::digest(record$payload, algo = "xxhash64", serialize = FALSE))) { + cache$remove(key) + return(list(hit = FALSE)) + } + list(hit = TRUE, value = unserialize(record$payload)) + }, error = function(e) { + cache$remove(key) + list(hit = FALSE) + }) } analysis_cache_set <- function(cache, key, value) { - if (!is.null(cache) && !is.null(key)) cache$set(key, serialize(value, NULL)) + if (!is.null(cache) && !is.null(key) && cache$capacity()$bytes > 0 && + as.numeric(utils::object.size(value)) <= cache$capacity()$bytes) { + payload <- serialize(value, NULL) + if (length(payload) <= cache$capacity()$bytes) { + cache$set(key, list(format = analysis_cache_format, payload = payload, + checksum = digest::digest(payload, algo = "xxhash64", serialize = FALSE))) + } + } invisible(value) } @@ -28,7 +51,9 @@ analysis_cache_set <- function(cache, key, value) { # function bodies nor defaults are evaluated. Both syntax and XML providers use # these facts across reparses, independently of declaration position. analysis_function_header <- function(document, text, symbol) { - cache <- analysis_cache(document, "function-headers") + context <- list(format = lapply(c("width", "digits", "scipen", "deparse.cutoff"), getOption), + formatter = get_signature) + cache <- analysis_cache(document, "function-headers", context) key <- digest::digest(list(symbol, text), algo = "xxhash64") found <- analysis_cache_get(cache, key) if (found$hit) return(found$value) diff --git a/R/member-analysis.R b/R/member-analysis.R index c08dd092..44591615 100644 --- a/R/member-analysis.R +++ b/R/member-analysis.R @@ -142,6 +142,11 @@ member_receiver_cacheable <- function(value, index, budget) { if (!length(value$type)) { return(all(vapply(value$possible_returns, member_receiver_cacheable, logical(1L), index, budget))) } + # Alias histories can start in a generic document context. The declared + # native surface belongs to the receiver's namespace, regardless of which + # package was selected while recovering the cursor. + owner <- member_package_context(index, value$member_package) + if (is.null(owner)) return(FALSE) # Recursive argument analysis must not preserve partial instance fields. # A native-backed class-only result has a complete declared member surface # independent of argument values; retain just that proven surface. @@ -149,10 +154,10 @@ member_receiver_cacheable <- function(value, index, budget) { is.null(value$slots) && is.null(value$function_expr) && is.null(value$closure) && is.null(value$binding_expr) && is.null(value$elements) && is.null(value$element_shape) && is.null(value$result_shape) && is.null(value$r6_class) && !isTRUE(value$open) && - (any(index$members[[value$type]] %in% index$native_factories, na.rm = TRUE) || - any(vapply(index$properties[[value$type]], function(property) { + (any(owner$members[[value$type]] %in% owner$native_factories, na.rm = TRUE) || + any(vapply(owner$properties[[value$type]], function(property) { length(property$type) == 1L && - any(index$members[[property$type]] %in% index$native_factories, na.rm = TRUE) + any(owner$members[[property$type]] %in% owner$native_factories, na.rm = TRUE) }, logical(1L)))) } diff --git a/R/member-completion.R b/R/member-completion.R index b27eb08d..abd70049 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -524,9 +524,9 @@ member_resolve_document <- function(name, index, bindings, budget, depth, trail) !member_head(item$expr, "function")) { paste(index$package, index$document_context_key, id, item$cache_prefix, sep = ":") } - cached <- if (!is.null(persistent_key)) cache$get(persistent_key) else NULL - if (!is.null(cached)) { - value <- unserialize(cached) + cached <- analysis_cache_get(cache, persistent_key) + if (cached$hit) { + value <- cached$value index$document_cache[[memo_key]] <- value return(value) } @@ -546,7 +546,7 @@ member_resolve_document <- function(name, index, bindings, budget, depth, trail) if (!is.null(cached)) { index$document_cache[[memo_key]] <- cached if (!is.null(persistent_key) && member_binding_cacheable(cached)) { - cache$set(persistent_key, serialize(cached, NULL)) + analysis_cache_set(cache, persistent_key, cached) } } value diff --git a/R/member-metadata.R b/R/member-metadata.R index cf80eb0e..b19a90c5 100644 --- a/R/member-metadata.R +++ b/R/member-metadata.R @@ -657,9 +657,8 @@ member_namespace_input <- function( if (is.null(generic)) next for (method in methods[startsWith(methods, paste0(generic$name, "."))]) { record <- member_binding(table, method, materialize = TRUE) - expected <- member_definition(definitions, method) if (!identical(record[[1L]], "value") || typeof(record[[2L]]) != "closure" || - !identical(member_function_syntax(record[[2L]]), expected)) { + !identical(record[[2L]], functions[[method]])) { generic_external <- union(generic_external, generic$name) } } diff --git a/R/namespace.R b/R/namespace.R index 38e00fdd..9dcb3a89 100644 --- a/R/namespace.R +++ b/R/namespace.R @@ -30,8 +30,9 @@ PackageNamespace <- R6::R6Class("PackageNamespace", fn <- get(funct, envir = private$namespace) if (!is.function(fn)) return(NULL) cached <- private$function_metadata$get(funct, NULL) + context <- lapply(c("width", "digits", "scipen", "deparse.cutoff"), getOption) # Identity also detects assignInNamespace()/trace() replacements. - if (!is.null(cached) && identical(cached$fn, fn)) return(cached) + if (!is.null(cached) && identical(cached$fn, fn) && identical(cached$context, context)) return(cached) args <- args(fn) sig <- NULL if (!is.null(args)) { @@ -40,7 +41,7 @@ PackageNamespace <- R6::R6Class("PackageNamespace", sig <- paste0(trimws(sig, which = "left"), collapse = "") sig <- gsub("^function\\s*", funct, sig) } - value <- list(fn = fn, signature = sig, + value <- list(fn = fn, context = context, signature = sig, formals = if (is.null(args)) NULL else formals(if (is.primitive(fn)) args else fn)) private$function_metadata$set(funct, value) @@ -48,10 +49,9 @@ PackageNamespace <- R6::R6Class("PackageNamespace", }, function_stub = function(funct) { - if (private$function_stubs$has(funct)) { - return(private$function_stubs$get(funct)) - } fn <- tryCatch(get0(funct, envir = private$namespace), error = function(e) NULL) + previous <- private$function_stubs$get(funct, NULL) + if (!is.null(previous) && identical(previous$fn, fn)) return(previous$value) stub <- if (!is.function(fn)) { NULL } else if (is.primitive(fn)) { @@ -61,7 +61,7 @@ PackageNamespace <- R6::R6Class("PackageNamespace", formals(fun) <- formals(fn) utils::removeSource(fun) } - private$function_stubs$set(funct, stub) + private$function_stubs$set(funct, list(fn = fn, value = stub)) stub } ), @@ -91,7 +91,7 @@ PackageNamespace <- R6::R6Class("PackageNamespace", private$function_metadata <- collections::dict() private$function_stubs <- collections::dict() private$lazydata <- as.character(names(.getNamespaceInfo(ns, "lazydata"))) - private$documentation <- collections::dict() + private$documentation <- ByteLruCache$new(2 * 1024^2, 128L) }, exists = function(objname, exported_only = TRUE) { @@ -154,17 +154,19 @@ PackageNamespace <- R6::R6Class("PackageNamespace", get_documentation = function(topic) { private$ensure_namespace() pkgname <- self$package_name - if (private$documentation$has(topic)) { - return(private$documentation$get(topic)) - } - identity <- tryCatch(package_metadata_identity(pkgname), error = function(e) NULL) + previous <- private$documentation$get(topic, NULL) + context <- list(libraries = .libPaths(), parser = get_help_rd, converter = convert_doc_string) + if (identical(previous$context, context) && !is.null(previous$identity) && + identical(previous$identity, tryCatch(package_metadata_help_identity(previous$hfile, pkgname), + error = function(e) NULL))) return(previous$value) + hfile <- utils::help((topic), (pkgname)) + identity <- tryCatch(package_metadata_help_identity(hfile, pkgname), error = function(e) NULL) cache_path <- if (!is.null(identity)) package_metadata_cache_path("documentation", identity, topic) cached <- package_metadata_cache_read(cache_path, identity) if (!is.null(cached)) { - private$documentation$set(topic, cached) + private$documentation$set(topic, list(context = context, identity = identity, hfile = hfile, value = cached)) return(cached) } - hfile <- utils::help((topic), (pkgname)) if (length(hfile) > 0) { doc <- get_help_rd(hfile) @@ -195,7 +197,7 @@ PackageNamespace <- R6::R6Class("PackageNamespace", } else { value <- list() } - private$documentation$set(topic, value) + private$documentation$set(topic, list(context = context, identity = identity, hfile = hfile, value = value)) package_metadata_cache_write(cache_path, identity, value) value }, diff --git a/R/package-cache.R b/R/package-cache.R index e687d7e0..1ce94024 100644 --- a/R/package-cache.R +++ b/R/package-cache.R @@ -1,15 +1,38 @@ # Shared storage for immutable package metadata. Providers choose their type, # identity/context, and validator; live functions and document state stay local. +# Content hashes are computed on first use and after filesystem changes. The +# change time and file identity detect replacements preserving size and mtime; +# access time is excluded because reading a database must not invalidate it. +package_metadata_file_checksum <- function(files) unname(tools::md5sum(files)) + +package_metadata_file_fingerprint <- local({ + cache <- NULL + function(files) { + if (is.null(cache)) cache <<- ByteLruCache$new(1024^2, 128L) + files <- sort(unique(files)) + info <- fs::file_info(files, fail = FALSE) + stamp <- list(files, as.numeric(info$size), info$type, as.numeric(info$modification_time), + as.numeric(info$change_time), info$device_id, info$inode) + key <- digest::digest(files, algo = "xxhash64") + previous <- cache$get(key) + if (!is.null(previous) && identical(previous$stamp, stamp)) return(previous$value) + hashes <- package_metadata_file_checksum(files) + if (any(is.na(hashes) & !is.na(info$size) & info$type != "directory")) stop("Cannot fingerprint package metadata files") + value <- digest::digest(list(files, hashes), algo = "xxhash64") + cache$set(key, list(stamp = stamp, value = value)) + value + } +}) + package_metadata_identity <- function(package, lib_paths = .libPaths(), context = NULL) { path <- find.package(package, lib.loc = lib_paths) files <- c(file.path(path, c("DESCRIPTION", "NAMESPACE")), unlist(lapply(c("R", "data", "help"), function(directory) { list.files(file.path(path, directory), pattern = "\\.(rdb|rdx|rds)$", full.names = TRUE) }), use.names = FALSE), list.files(file.path(path, "libs"), full.names = TRUE, recursive = TRUE)) - info <- file.info(files) list(package = package, path = path, version = as.character(utils::packageVersion(package, lib.loc = lib_paths)), r = as.character(getRversion()), - files = digest::digest(list(files, info$size, as.numeric(info$mtime)), algo = "xxhash64"), context = context) + files = package_metadata_file_fingerprint(files), context = context) } package_metadata_signature <- function(value) { @@ -42,10 +65,112 @@ package_metadata_namespace_state <- function(ns) { package_metadata_live_identity <- function(package, lib_paths = .libPaths(), context = NULL) { identity <- package_metadata_identity(package, lib_paths, context) identity$namespace <- package_metadata_namespace_state(asNamespace(package)) + identity$bindings <- s3_metadata_context(package) + identity$cacheable <- !is.null(identity$bindings) identity } -package_metadata_cache_format <- 2L +# Help can come from a library other than the first installed/loaded namespace. +# Track the database actually read, without hashing unrelated native binaries +# on every documentation request. +package_metadata_help_identity <- function(hfile, package = NULL) { + paths <- as.character(hfile) + if (!length(paths)) { + if (is.null(package)) return(NULL) + paths <- file.path(find.package(package), "help", ".missing-topic") + } + roots <- unique(dirname(dirname(paths))) + files <- unlist(lapply(roots, function(root) { + c(file.path(root, c("DESCRIPTION", "Meta/Rd.rds", "help/AnIndex")), + list.files(file.path(root, "help"), pattern = "\\.(rdb|rdx|rds)$", full.names = TRUE)) + }), use.names = FALSE) + list(package = basename(roots[[1L]]), path = roots, r = as.character(getRversion()), + files = package_metadata_file_fingerprint(files)) +} + +# R caches lazy-load database bytes by filename and offers no public flush API. +# Read an immutable copy under its content fingerprint so replacing the actual +# database cannot reuse R's old bytes. Copies are made only on a documentation +# miss, reused for other topics, and removed with the session temporary folder. +package_metadata_help_file <- local({ + cache <- NULL + function(hfile) { + identity <- package_metadata_help_identity(hfile) + paths <- as.character(hfile) + if (is.null(identity)) return(hfile) + if (is.null(cache)) cache <<- ByteLruCache$new(package_metadata_cache_max_bytes, 128L) + root <- file.path(tempdir(), "languageserver-help", identity$files) + copies <- vapply(paths, function(path) { + package <- basename(dirname(dirname(path))) + directory <- file.path(root, package, "help") + database <- file.path(dirname(path), paste0(package, c(".rdb", ".rdx"))) + targets <- file.path(directory, basename(database)) + if (!all(file.exists(targets))) { + dir.create(directory, recursive = TRUE, showWarnings = FALSE) + if (!all(file.copy(database, targets, overwrite = TRUE))) stop("Cannot copy help database") + } + file.path(directory, basename(path)) + }, character(1L), USE.NAMES = FALSE) + if (!cache$has(root)) { + size <- sum(file.info(list.files(root, full.names = TRUE, recursive = TRUE))$size) + before <- cache$keys() + cache$set(root, root, additional_bytes = size) + if (!cache$has(root)) { + unlink(root, recursive = TRUE) + stop("Help database exceeds cache budget") + } + for (expired in setdiff(before, cache$keys())) unlink(expired, recursive = TRUE) + } else { + cache$get(root) + } + attributes(copies) <- attributes(hfile) + copies + } +}) + +package_metadata_help_context <- local({ + previous <- NULL + key <- NULL + function() { + context <- list(locale = Sys.getlocale(), + options = lapply(c("width", "useFancyQuotes", "help.htmlmath", "help.option"), getOption), + renderer = list(get_help_rd, tools::Rd2txt, tools::Rd2HTML)) + if (!identical(previous, context)) { + previous <<- context + key <<- digest::digest(context, algo = "xxhash64") + } + key + } +}) + +package_metadata_cache_format <- 3L +package_metadata_cache_max_bytes <- 256 * 1024^2 + +package_metadata_server_load_state <- new.env(parent = emptyenv()) + +package_metadata_server_loaded <- function() { + ns <- asNamespace("languageserver") + path <- getNamespaceInfo(ns, "path") + dll <- getLoadedDLLs()[["languageserver"]][["path"]] + files <- c(list.files(file.path(path, "R"), full.names = TRUE), dll) + package_metadata_server_load_state$namespace <- ns + package_metadata_server_load_state$files <- unname(tools::md5sum(files)) +} + +package_metadata_server_constant <- function(value, depth = 0L) { + if (depth > 12L || is.object(value)) return(FALSE) + if (is.atomic(value) || is.null(value)) return(length(value) <= 10000L) + if (typeof(value) == "closure") return(TRUE) + if (is.call(value) || is.expression(value) || is.pairlist(value)) return(TRUE) + is.list(value) && all(vapply(value, package_metadata_server_constant, logical(1L), depth + 1L)) +} + +package_metadata_server_syntax <- function(value) { + if (typeof(value) == "closure") return(deparse1(member_function_syntax(value))) + if (is.call(value) || is.expression(value) || is.pairlist(value)) return(deparse1(value)) + if (is.list(value)) return(lapply(value, package_metadata_server_syntax)) + value +} package_metadata_cache_root <- function() { value <- getOption("languageserver.package_cache_dir", @@ -59,34 +184,37 @@ package_metadata_cache_directory <- function() { if (identical(value, FALSE)) NULL else file.path(value, "package-metadata") } +package_metadata_cache_allowed <- function(identity) { + is.list(identity) && !identical(identity$cacheable, FALSE) && + !(is.list(identity$context) && identical(identity$context$cacheable, FALSE)) +} + package_metadata_cache_server <- local({ identity <- NULL + previous <- NULL function() { - if (!is.null(identity)) return(identity) ns <- asNamespace("languageserver") + if (!identical(package_metadata_server_load_state$namespace, ns)) package_metadata_server_loaded() values <- list() for (name in ls(ns, all.names = TRUE)) { if (identical(name, ".packageName")) next record <- member_binding(ns, name, materialize = TRUE) value <- record[[2L]] if (typeof(value) == "closure") { - values[name] <- list(deparse1(member_function_syntax(value))) + values[name] <- list(value) } else if (is.environment(value) && "R6ClassGenerator" %in% attr(value, "class", exact = TRUE)) { methods <- list(public = value$public_methods, private = value$private_methods, active = value$active) - values[name] <- list(lapply(methods, function(section) { - lapply(section, function(method) { - if (typeof(method) == "closure") deparse1(member_function_syntax(method)) - }) - })) - } else if (!is.object(value) && is.atomic(value) && length(value) <= 10000L) { - values[name] <- list(value) - } else if (is.list(value) && all(vapply(value, is.atomic, logical(1L)))) { + values[name] <- list(methods) + } else if (package_metadata_server_constant(value)) { values[name] <- list(value) } } - dll <- getLoadedDLLs()[["languageserver"]][["path"]] + state <- list(namespace = ns, values = values, files = package_metadata_server_load_state$files) + if (!is.null(identity) && identical(state, previous)) return(identity) + previous <<- state identity <<- list(version = getNamespaceInfo(ns, "spec")[["version"]], - implementation = digest::digest(values, algo = "xxhash64"), native = unname(tools::md5sum(dll))) + implementation = digest::digest(lapply(values, package_metadata_server_syntax), algo = "xxhash64"), + loaded_files = package_metadata_server_load_state$files) identity } }) @@ -94,19 +222,23 @@ package_metadata_cache_server <- local({ package_metadata_cache_path <- function(type, identity, key = NULL) { directory <- package_metadata_cache_directory() if (is.null(directory)) return(NULL) - if (is.list(identity$context) && identical(identity$context$cacheable, FALSE)) return(NULL) + if (!package_metadata_cache_allowed(identity)) return(NULL) hash <- digest::digest(list(format = package_metadata_cache_format, type = type, key = key, identity = identity, server = package_metadata_cache_server()), algo = "xxhash64") file.path(directory, paste0(identity$package, "-", type, "-", hash, ".rds")) } package_metadata_cache_read <- function(path, identity, validate = is.list) { - if (is.null(path) || !file.exists(path)) return(NULL) + if (identical(package_metadata_cache_root(), FALSE) || !package_metadata_cache_allowed(identity) || + is.null(path) || !file.exists(path)) return(NULL) tryCatch({ + size <- file.info(path)$size + if (is.na(size) || size > package_metadata_cache_max_bytes) return(NULL) record <- readRDS(path) - if (!identical(record$format, package_metadata_cache_format) || !identical(record$server, package_metadata_cache_server()) || + if (!is.list(record) || is.object(record) || !identical(record$format, package_metadata_cache_format) || + !identical(record$server, package_metadata_cache_server()) || !identical(record$identity, identity) || - !is.raw(record$payload) || + !is.raw(record$payload) || length(record$payload) > package_metadata_cache_max_bytes || !identical(record$checksum, digest::digest(record$payload, algo = "xxhash64", serialize = FALSE))) return(NULL) value <- unserialize(record$payload) if (!isTRUE(validate(value))) return(NULL) @@ -116,7 +248,9 @@ package_metadata_cache_read <- function(path, identity, validate = is.list) { } package_metadata_cache_write <- function(path, identity, value) { - if (is.null(path)) return(invisible(NULL)) + if (identical(package_metadata_cache_root(), FALSE) || !package_metadata_cache_allowed(identity) || + is.null(path)) return(invisible(NULL)) + if (as.numeric(utils::object.size(value)) > package_metadata_cache_max_bytes) return(invisible(NULL)) temporary <- NULL on.exit(if (!is.null(temporary)) unlink(temporary), add = TRUE) tryCatch(suppressWarnings({ @@ -124,6 +258,7 @@ package_metadata_cache_write <- function(path, identity, value) { dir.create(directory, recursive = TRUE, showWarnings = FALSE) temporary <- tempfile("metadata-", tmpdir = directory) payload <- serialize(value, NULL) + if (length(payload) > package_metadata_cache_max_bytes) return(invisible(NULL)) saveRDS(list(format = package_metadata_cache_format, server = package_metadata_cache_server(), identity = identity, checksum = digest::digest(payload, algo = "xxhash64", serialize = FALSE), payload = payload), temporary) if (!file.rename(temporary, path)) { @@ -137,7 +272,7 @@ package_metadata_cache_write <- function(path, identity, value) { order <- order(info$mtime, decreasing = TRUE, na.last = TRUE) sizes <- info$size[order] sizes[is.na(sizes)] <- 0 - expired <- order[seq_along(order) > 512L | cumsum(sizes) > 256 * 1024^2] + expired <- order[seq_along(order) > 512L | cumsum(sizes) > package_metadata_cache_max_bytes] if (length(expired)) unlink(files[expired]) }), error = function(e) NULL) invisible(NULL) diff --git a/R/s3-metadata.R b/R/s3-metadata.R index 68862b61..a6042a52 100644 --- a/R/s3-metadata.R +++ b/R/s3-metadata.R @@ -116,7 +116,9 @@ s3_function_record <- function(fn, name, package) { syntax <- if (typeof(fn) == "closure") member_function_syntax(fn) else NULL arguments <- if (is.null(syntax)) args(fn) else NULL formals <- if (!is.null(syntax)) syntax[[2L]] else if (is.function(arguments)) formals(arguments) else NULL - generic <- s3_generic_descriptor(syntax) + foreign_environment <- typeof(fn) == "closure" && !isNamespace(environment(fn)) && + !identical(environment(fn), baseenv()) + generic <- if (!foreign_environment) s3_generic_descriptor(syntax) summary <- NULL for (candidate in s3_summary_names[[owner]]) { original <- member_binding(asNamespace(owner), candidate, materialize = TRUE) @@ -324,7 +326,10 @@ s3_metadata_context <- function(packages) { owner <- if (typeof(value) == "closure" && isNamespace(environment(value))) { unname(getNamespaceName(environment(value))) } - list(kind = record[[1L]], owner = owner, syntax = if (typeof(value) == "closure") deparse1(member_function_syntax(value)), + list(kind = record[[1L]], owner = owner, + foreign_environment = typeof(value) == "closure" && !isNamespace(environment(value)) && + !identical(environment(value), baseenv()), + syntax = if (typeof(value) == "closure") deparse1(member_function_syntax(value)), primitive = if (is.primitive(value)) name) }), names) table <- member_binding(ns, ".__S3MethodsTable__.")[[2L]] diff --git a/R/utils.R b/R/utils.R index 571cc75f..9a6ccf73 100644 --- a/R/utils.R +++ b/R/utils.R @@ -588,9 +588,11 @@ find_doc_item <- function(doc, tag) { } get_help_rd <- function(hfile) { - getNamespace("utils")$.getHelpFile(hfile) + getNamespace("utils")$.getHelpFile(package_metadata_help_file(hfile)) } +package_help_owner <- new.env(parent = emptyenv()) + get_help <- function(hfile, format = c("html", "text")) { format <- match.arg(format) @@ -601,11 +603,16 @@ get_help <- function(hfile, format = c("html", "text")) { } pkgname <- basename(dirname(dirname(paths[[1]]))) - identity <- tryCatch(package_metadata_identity(pkgname), error = function(e) NULL) + identity <- tryCatch(package_metadata_help_identity(hfile), error = function(e) NULL) + context <- package_metadata_help_context() + cache <- analysis_cache(package_help_owner, "rendered-help", context) + key <- digest::digest(list(paths, identity, format), algo = "xxhash64") + found <- if (!is.null(identity)) analysis_cache_get(cache, key) else list(hit = FALSE) + if (found$hit) return(found$value) cache_path <- if (!is.null(identity)) package_metadata_cache_path(paste0("help-", format), identity, - list(paths, locale = Sys.getlocale("LC_MESSAGES"))) + list(paths, context = context)) cached <- package_metadata_cache_read(cache_path, identity, is.character) - if (!is.null(cached)) return(cached) + if (!is.null(cached)) return(analysis_cache_set(cache, key, cached)) rd <- get_help_rd(hfile) if (format == "html") { @@ -623,6 +630,7 @@ get_help <- function(hfile, format = c("html", "text")) { result <- enc2utf8(result) package_metadata_cache_write(cache_path, identity, result) + if (!is.null(identity)) analysis_cache_set(cache, key, result) result } diff --git a/R/workspace.R b/R/workspace.R index c99a14d9..b18a8d08 100644 --- a/R/workspace.R +++ b/R/workspace.R @@ -102,6 +102,7 @@ ByteLruCache <- R6::R6Class( invisible(NULL) }, size = function() private$entries$size(), + capacity = function() list(bytes = private$max_bytes, entries = private$max_entries), keys = function() private$entries$keys(), bytes = function() private$current_bytes ) @@ -379,7 +380,7 @@ Workspace <- R6::R6Class("Workspace", for (pkgname in self$loaded_packages) { self$namespaces$set(pkgname, PackageNamespace$new(pkgname)) } - self$help_cache <- collections::dict() + self$help_cache <- ByteLruCache$new(2 * 1024^2, 128L) parse_cache_mb <- lsp_settings$get("parse_cache_max_mb") if (!is.numeric(parse_cache_mb) || length(parse_cache_mb) != 1L || is.na(parse_cache_mb) || parse_cache_mb < 0) { @@ -635,7 +636,9 @@ Workspace <- R6::R6Class("Workspace", ) if (length(hfile) > 0) { - key <- as.character(hfile) + identity <- tryCatch(package_metadata_help_identity(hfile), error = function(e) NULL) + key <- digest::digest(list(paths = as.character(hfile), identity = identity, + context = package_metadata_help_context(), rich = lsp_settings$get("rich_documentation")), algo = "xxhash64") if (self$help_cache$has(key)) { self$help_cache$get(key) } else { diff --git a/R/zzz.R b/R/zzz.R index 755d697e..45cea5db 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,5 +1,6 @@ .onLoad <- function(...) { - user_parser_hooks <- getOption("languageserver.parser_hooks") - parser_hooks[names(user_parser_hooks)] <<- user_parser_hooks - invisible() + package_metadata_server_loaded() + user_parser_hooks <- getOption("languageserver.parser_hooks") + parser_hooks[names(user_parser_hooks)] <<- user_parser_hooks + invisible() } diff --git a/README.md b/README.md index e7f90fc0..b23958a2 100644 --- a/README.md +++ b/README.md @@ -304,6 +304,15 @@ It keeps up to 512 entries and 256 MiB, removing older entries as needed. Packag file, loaded namespace, dependency, registry, R version and server implementation changes invalidate cached results; incompatible or corrupt entries are rebuilt. Document-dependent inference remains local to the current document and its metadata revision. +File contents are checksummed on first use and after changes to file identity, +size, modification time or change time; warm lookups reuse the checksum. Help +uses the actual database location, and checks its identity before using memory +or disk results. Immutable help database copies live under +`file.path(tempdir(), "languageserver-help")` for the session, avoiding stale +bytes in R's own lazy-load cache without relying on internal R APIs. Rendered +help and documentation memory caches are bounded. Server keys cover the cache +schema, loaded R/native implementation, functions and inert constants, so +incompatible server versions or development builds do not share entries. Conversions with unresolved input classes can offer the common members of known method results as suggestions, marked `[possible receiver]` or `[possible member]`. These suggestions do not establish the receiver's type; known conflicting method diff --git a/tests/testthat/test-analysis-cache.R b/tests/testthat/test-analysis-cache.R index 6be62b22..38b7be58 100644 --- a/tests/testthat/test-analysis-cache.R +++ b/tests/testthat/test-analysis-cache.R @@ -42,6 +42,44 @@ test_that("Analysis domains isolate contexts, bound storage and clone cached val expect_false(analysis_cache_get(bounded, "large")$hit) }) +test_that("Old handles, incompatible formats and changed limits cannot poison a new domain", { + owner <- new.env(parent = emptyenv()) + old <- analysis_cache(owner, "fixture", "old", max_entries = 3L) + analysis_cache_set(old, "value", "old") + current <- analysis_cache(owner, "fixture", "current", max_entries = 3L) + analysis_cache_set(current, "value", "current") + analysis_cache_set(old, "value", "stale writer") + expect_identical(analysis_cache_get(current, "value")$value, "current") + for (i in 1:3) analysis_cache_set(current, as.character(i), i) + smaller <- analysis_cache(owner, "fixture", "current", max_entries = 1L) + expect_identical(smaller$size(), 0L) + for (i in 1:3) analysis_cache_set(smaller, as.character(i), i) + expect_identical(smaller$size(), 1L) + smaller$set("bad", as.raw(c(1, 2, 3))) + expect_false(analysis_cache_get(smaller, "bad")$hit) + analysis_cache_set(smaller, "bad", list(value = 1)) + record <- smaller$get("bad") + record$payload <- serialize(list(value = 2), NULL) + smaller$set("bad", record) + expect_false(analysis_cache_get(smaller, "bad")$hit) + analysis_cache_set(smaller, "value", "old format") + state <- owner$analysis_caches$fixture + state$runtime$format <- -1L + owner$analysis_caches$fixture <- state + expect_identical(analysis_cache(owner, "fixture", "current", max_entries = 1L)$size(), 0L) +}) + +test_that("Source signatures account for current formatting options", { + document <- Document$new("file:///format-options.R", language = "r") + withr::local_options(scipen = 0) + original <- analysis_function_header(document, "function(value = 1e5)", "f")$signature + withr::local_options(scipen = 999) + current <- analysis_function_header(document, "function(value = 1e5)", "f")$signature + expected <- get_signature("f", str2expression(c("function(value = 1e5)", "NULL"))[[1L]]) + expect_identical(current, expected) + expect_false(identical(original, current)) +}) + test_that("Source signatures and documentation survive reparses and retain current inputs", { lines <- c("#' Describe a source function.", "#' @param argument The value.", "target <- function(argument, option = 1) argument", "target(1, 2)") diff --git a/tests/testthat/test-member-analysis.R b/tests/testthat/test-member-analysis.R index e76e5231..9f643a12 100644 --- a/tests/testthat/test-member-analysis.R +++ b/tests/testthat/test-member-analysis.R @@ -236,6 +236,32 @@ test_that("Recursive arguments cache only a proven native class surface", { expect_false(member_receiver_cacheable(member_value(reason = "recursion"), index, budget)) }) +test_that("Native surface reuse validates the receiver namespace in a generic context", { + owner <- member_generic_index("native_run <- function() .Call('never')") + owner$package <- "nativeowner" + owner$members$Frame <- c(run = "native_run") + owner$native_factories <- "native_run" + index <- member_generic_index("") + index$namespace_indices <- list(nativeowner = as.list(owner)) + budget <- member_request_budget() + budget$transient <- TRUE + value <- member_value(type = "Frame", member_package = "nativeowner", + fields = list(partial = member_value(reason = "recursion"))) + possible <- member_value(reason = "possible_result", possible_returns = list(value)) + expect_false(member_receiver_cacheable(possible, index, budget)) + cached <- member_receiver_cache_value(possible, index, budget) + expect_identical(cached$possible_returns[[1L]]$type, "Frame") + expect_identical(cached$possible_returns[[1L]]$member_package, "nativeowner") + expect_null(cached$possible_returns[[1L]]$fields) + expect_true(member_binding_cacheable(cached)) + index$namespace_indices$nativeowner$native_factories <- character() + expect_null(member_receiver_cache_value(possible, index, budget)) + index$members <- owner$members + index$native_factories <- owner$native_factories + index$namespace_indices <- list() + expect_null(member_receiver_cache_value(possible, index, budget)) +}) + test_that("Only standalone final ordinary identifier edits bypass parse waits", { fixture <- provider_fixture(c("x <- list(a = 1)", "")) edit <- function(doc, text) { diff --git a/tests/testthat/test-package-metadata-cache.R b/tests/testthat/test-package-metadata-cache.R index 2e208852..c5fb4ff4 100644 --- a/tests/testthat/test-package-metadata-cache.R +++ b/tests/testthat/test-package-metadata-cache.R @@ -43,6 +43,77 @@ test_that("Persistent caching can be disabled without affecting package preparat expect_silent(package_metadata_cache_write(NULL, list(), list())) }) +test_that("Disabling disk caching also rejects previously computed paths", { + withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) + identity <- list(package = "disablefixture") + path <- package_metadata_cache_path("fixture", identity) + package_metadata_cache_write(path, identity, list(value = 1)) + unsafe <- identity + unsafe$context <- list(cacheable = FALSE) + expect_null(package_metadata_cache_read(path, unsafe)) + package_metadata_cache_write(path, unsafe, list(value = 2)) + expect_identical(unserialize(readRDS(path)$payload), list(value = 1)) + withr::local_options(languageserver.package_cache_dir = FALSE) + expect_null(package_metadata_cache_read(path, identity)) + package_metadata_cache_write(path, identity, list(value = 2)) + expect_identical(unserialize(readRDS(path)$payload), list(value = 1)) +}) + +test_that("Server fingerprints refresh after live implementation and nested constant changes", { + original <- package_metadata_cache_server() + ns <- asNamespace("languageserver") + update <- function(name, value) { + unlockBinding(name, ns) + assign(name, value, ns) + lockBinding(name, ns) + } + constants <- member_base_intrinsics + withr::defer(update("member_base_intrinsics", constants)) + update("member_base_intrinsics", c(constants, "cache_review_fixture")) + expect_false(identical(package_metadata_cache_server(), original)) + update("member_base_intrinsics", constants) + expect_identical(package_metadata_cache_server(), original) + expect_true(package_metadata_server_constant(list(nested = list(value = TRUE)))) + expect_false(identical(package_metadata_server_syntax(list(nested = list(value = TRUE))), + package_metadata_server_syntax(list(nested = list(value = FALSE))))) + expect_false(package_metadata_server_constant(list(runtime = new.env()))) +}) + +test_that("Server file compatibility describes the loaded implementation", { + root <- withr::local_tempdir() + dir.create(file.path(root, "R")) + native <- file.path(root, "server-native") + writeBin(charToRaw("first"), native) + previous <- as.list(package_metadata_server_load_state) + withr::defer({ + package_metadata_server_load_state$files <- previous$files + package_metadata_server_load_state$namespace <- previous$namespace + }) + load <- package_metadata_server_loaded + environment(load) <- list2env(list(getLoadedDLLs = function() list(languageserver = list(path = native)), + getNamespaceInfo = function(ns, which) root), parent = environment(load)) + load() + loaded <- package_metadata_cache_server() + writeBin(charToRaw("other"), native) + expect_identical(package_metadata_cache_server(), loaded) + load() + expect_false(identical(package_metadata_cache_server(), loaded)) +}) + +test_that("Oversized and malformed persistent entries are cache misses", { + withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) + testthat::local_mocked_bindings(package_metadata_cache_max_bytes = 512, .package = "languageserver") + identity <- list(package = "boundedfixture") + path <- package_metadata_cache_path("fixture", identity) + package_metadata_cache_write(path, identity, raw(1000L)) + expect_false(file.exists(path)) + dir.create(dirname(path), recursive = TRUE) + writeBin(raw(1000L), path) + expect_null(package_metadata_cache_read(path, identity)) + saveRDS("invalid record", path) + expect_null(package_metadata_cache_read(path, identity)) +}) + test_that("Cache types, format revisions and server versions remain isolated", { withr::local_options(languageserver.package_cache_dir = withr::local_tempdir()) identity <- list(package = "fixture", revision = 1L) @@ -67,6 +138,30 @@ test_that("Cache types, format revisions and server versions remain isolated", { expect_null(package_metadata_cache_read(path, identity)) }) +test_that("Content fingerprints are reused and detect replacements preserving size and mtime", { + root <- withr::local_tempdir() + path <- file.path(root, "fixture.rds") + writeBin(charToRaw("first"), path) + first <- package_metadata_file_fingerprint(path) + checksum <- package_metadata_file_checksum + computed <- 0L + testthat::local_mocked_bindings(package_metadata_file_checksum = function(files) { + computed <<- computed + 1L + checksum(files) + }, .package = "languageserver") + expect_identical(package_metadata_file_fingerprint(path), first) + expect_identical(computed, 0L) + stamp <- file.info(path) + writeBin(charToRaw("other"), path) + Sys.setFileTime(path, stamp$mtime) + expect_identical(file.info(path)$size, stamp$size) + expect_equal(file.info(path)$mtime, stamp$mtime) + expect_false(identical(package_metadata_file_fingerprint(path), first)) + expect_identical(computed, 1L) + expect_silent(package_metadata_file_fingerprint(path)) + expect_identical(computed, 1L) +}) + test_that("Loaded namespace changes cannot poison models for another library", { root <- withr::local_tempdir() withr::local_options(languageserver.package_cache_dir = file.path(root, "cache")) @@ -79,11 +174,17 @@ test_that("Loaded namespace changes cannot poison models for another library", { source <- file.path(root, paste0("source-", field)) dir.create(source) dir.create(file.path(source, "R")) + dir.create(file.path(source, "man")) writeLines(c("Package: lscachefixture", "Version: 0.0.1", "Title: Cache Test Fixture", "Description: Test package metadata cache invalidation.", "License: MIT", "Author: Test", "Maintainer: Test "), file.path(source, "DESCRIPTION")) - writeLines("export(api)", file.path(source, "NAMESPACE")) - writeLines(paste0("api <- list(", field, " = TRUE)"), file.path(source, "R", "api.R")) + writeLines(c("export(api, target, adapt)", "S3method(adapt, default)"), file.path(source, "NAMESPACE")) + writeLines(c(paste0("api <- list(", field, " = TRUE)"), "target <- function(value = 1e5) value", + "adapt <- function(x) UseMethod('adapt')", "adapt.default <- function(x) list(done = TRUE)"), + file.path(source, "R", "api.R")) + writeLines(c("\\name{api}", "\\alias{api}", if (field == "new") "\\alias{late_topic}", + paste0("\\title{The ", field, " documentation}"), + paste0("\\description{The ", field, " description.}")), file.path(source, "man", "api.Rd")) result <- callr::rcmd("INSTALL", cmdargs = c(paste0("--library=", lib), source), stdout = "|", stderr = "|", system_profile = FALSE, user_profile = FALSE) expect_identical(result$status, 0L) @@ -95,6 +196,41 @@ test_that("Loaded namespace changes cannot poison models for another library", { .libPaths(c(first_lib, original)) first <- member_prepare_package(package) expect_identical(names(first$roots$api$fields), "old") + namespace <- PackageNamespace$new(package) + expect_match(namespace$get_documentation("api")$title, "old documentation", fixed = TRUE) + expect_identical(namespace$get_documentation("late_topic"), list()) + expect_false(is.null(package_metadata_help_identity(character(), package))) + first_help <- utils::help("api", (package), lib.loc = first_lib) + second_help <- utils::help("api", (package), lib.loc = second_lib) + expect_false(identical(package_metadata_help_identity(first_help), package_metadata_help_identity(second_help))) + expect_match(get_help(second_help, "text"), "new description", fixed = TRUE) + workspace <- Workspace$new(NULL) + expect_match(workspace$get_help("api", package), "old documentation", fixed = TRUE) + # Replace the installed help database without changing the version or + # loaded namespace. R's own lazy-load database cache must refresh too. + files <- list.files(file.path(second_lib, package, "help"), full.names = TRUE) + for (source in files) { + destination <- file.path(first_lib, package, "help", basename(source)) + stamp <- file.info(destination)$mtime + expect_true(file.copy(source, destination, overwrite = TRUE)) + Sys.setFileTime(destination, stamp) + } + expect_true(file.copy(file.path(second_lib, package, "Meta/Rd.rds"), + file.path(first_lib, package, "Meta/Rd.rds"), overwrite = TRUE)) + expect_match(namespace$get_documentation("api")$title, "new documentation", fixed = TRUE) + expect_match(namespace$get_documentation("late_topic")$title, "new documentation", fixed = TRUE) + expect_match(workspace$get_help("api", package), "new documentation", fixed = TRUE) + expect_match(get_help(first_help, "text"), "new description", fixed = TRUE) + # A same-version, same-size DESCRIPTION replacement changes the general + # package identity even when its modification time is preserved. + before <- package_metadata_identity(package) + description <- file.path(first_lib, package, "DESCRIPTION") + stamp <- file.info(description) + text <- readLines(description) + writeLines(sub("Cache Test Fixture", "Cache Best Fixture", text, fixed = TRUE), description) + Sys.setFileTime(description, stamp$mtime) + expect_identical(file.info(description)$size, stamp$size) + expect_false(identical(package_metadata_identity(package), before)) second <- member_prepare_package(package, c(second_lib, original)) expect_identical(names(second$roots$api$fields), "old") unloadNamespace(package) @@ -102,12 +238,38 @@ test_that("Loaded namespace changes cannot poison models for another library", { expect_identical(names(third$roots$api$fields), "new") expect_false(identical(second$identity$namespace, third$identity$namespace)) ns <- asNamespace(package) + withr::local_options(scipen = 0) + signature <- namespace$get_signature("target") + withr::local_options(scipen = 999) + expect_false(identical(namespace$get_signature("target"), signature)) + expect_identical(names(formals(namespace$get_diagnostic_stub("target"))), "value") + replacement <- function(revised = TRUE) revised + environment(replacement) <- ns + unlockBinding("target", ns) + assign("target", replacement, ns) + lockBinding("target", ns) + expect_identical(names(namespace$get_formals("target")), "revised") + expect_identical(names(formals(namespace$get_diagnostic_stub("target"))), "revised") unlockBinding("api", ns) assign("api", list(runtime = TRUE), ns) lockBinding("api", ns) changed <- member_prepare_package(package, c(second_lib, original)) expect_identical(names(changed$roots$api$fields), "runtime") expect_false(identical(changed$identity$namespace, third$identity$namespace)) + registered <- ns$adapt.default + bindings <- s3_metadata_context(package) + expect_false(is.null(bindings)) + foreign <- registered + environment(foreign) <- new.env(parent = ns) + expect_identical(member_function_syntax(registered), member_function_syntax(foreign)) + registerS3method("adapt", "default", foreign, envir = ns) + expect_false(identical(s3_metadata_context(package), bindings)) + changed <- member_prepare_package(package, c(second_lib, original)) + expect_identical(changed$generic_external, "adapt") + other <- registered + environment(other) <- new.env(parent = ns) + registerS3method("adapt", "default", other, envir = ns) + expect_identical(member_prepare_package(package, c(second_lib, original))$generic_external, "adapt") }) test_that("S3 catalogs reuse cached metadata and detect registry changes", { From 17d2fea48338d47ac46972de95a54ddd6c64e2d4 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 16:26:39 +0800 Subject: [PATCH 11/12] Reuse package validation facts and enforce inference work budgets --- R/member-completion.R | 6 +- R/member-inference.R | 35 ++++--- R/member-metadata.R | 12 +-- R/package-cache.R | 75 ++++++++++++-- R/s3-metadata.R | 11 +- inst/benchmarks/README.md | 71 +++++++++++++ inst/benchmarks/member-budget.R | 101 +++++++++++++++++++ inst/benchmarks/package-cache.R | 46 +++++++++ src/languageserver.c | 1 + src/member.c | 10 ++ src/member.h | 1 + tests/testthat/test-member-completion.R | 4 +- tests/testthat/test-member-reuse-budget.R | 26 +++++ tests/testthat/test-package-metadata-cache.R | 76 +++++++++++++- 14 files changed, 441 insertions(+), 34 deletions(-) create mode 100644 inst/benchmarks/member-budget.R create mode 100644 inst/benchmarks/package-cache.R diff --git a/R/member-completion.R b/R/member-completion.R index abd70049..ce472c93 100644 --- a/R/member-completion.R +++ b/R/member-completion.R @@ -979,10 +979,12 @@ member_request_budget <- function() { # time spent descheduled on a busy host; a wall deadline still bounds latency. # Explicit caller deadlines remain strict and never receive an extension. member_budget_expired <- function(budget, clock) { - if (clock[[3L]] <= budget$deadline) return(FALSE) - if (is.null(budget$scheduled_deadline) || !identical(budget$deadline, budget$scheduled_deadline)) return(TRUE) + if (is.null(budget$scheduled_deadline) || !identical(budget$deadline, budget$scheduled_deadline)) { + return(clock[[3L]] > budget$deadline) + } cpu <- max(0, clock[[1L]] + clock[[2L]] - budget$cpu_started) if (clock[[3L]] >= budget$wall_deadline || cpu >= budget$cpu_limit) return(TRUE) + if (clock[[3L]] <= budget$deadline) return(FALSE) budget$time_limit <- min(budget$cpu_limit, max(budget$time_limit * 2, cpu * 2)) budget$deadline <- budget$scheduled_deadline <- min(budget$wall_deadline, clock[[3L]] + budget$time_limit - cpu) diff --git a/R/member-inference.R b/R/member-inference.R index b24740a3..8656251a 100644 --- a/R/member-inference.R +++ b/R/member-inference.R @@ -531,6 +531,7 @@ member_infer <- function( budget$exhausted <- FALSE budget$transient <- FALSE } + if (isTRUE(budget$exhausted)) return(member_value(reason = "budget")) budget$remaining <- budget$remaining - 1L # Package installation byte-compiles this engine. In development sessions, # start timing after R's first-call JIT compilation, before traversing ASTs. @@ -600,6 +601,10 @@ member_infer <- function( } # Flow records keep early returns separate from fall-through values. flow <- function(node, env) { + if (isTRUE(budget$exhausted)) { + return(list(value = member_value(reason = "budget"), env = env, + returns = member_value(type = ".never"), falls = TRUE)) + } env <- member_s4_effect(node, index, env) if (member_head(node, "{")) { state <- list( @@ -607,7 +612,7 @@ member_infer <- function( returns = member_value(type = ".never"), falls = TRUE ) for (child in as.list(node)[-1L]) { - if (!state$falls) break + if (!state$falls || isTRUE(budget$exhausted)) break next_state <- flow(child, state$env) state$returns <- member_join(state$returns, next_state$returns) if (isTRUE(context$r6_initialize)) { @@ -1172,6 +1177,7 @@ member_infer <- function( callee <- NULL if (!intrinsic(head)) { callee <- infer(expr[[1L]]) + if (isTRUE(budget$exhausted)) return(member_value(reason = "budget")) if (!is.null(callee$function_key) && is.null(callee$metadata)) { self <- callee$receiver_value key <- if (is.null(self)) callee$function_key else paste(self$type, callee$function_key, sep = "|") @@ -1196,21 +1202,24 @@ member_infer <- function( return(member_literal(length(dots$elements) == 0L)) } } - actuals <- lapply(args, function(arg) { - if (identical(arg, quote(expr = ))) member_value(type = ".missing") else infer(arg) - }) + actuals <- vector("list", length(args)) + names(actuals) <- names(args) + for (i in seq_along(args)) { + actuals[[i]] <- if (identical(unname(args[i]), list(quote(expr = )))) member_value(type = ".missing") else infer(args[[i]]) + if (isTRUE(budget$exhausted)) return(member_value(reason = "budget")) + } # Expand syntactic dots from a known argument list without evaluating it. - expanded <- list() open_dots <- FALSE - for (i in seq_along(args)) { - if (identical(args[[i]], as.name("...")) && !is.null(actuals[[i]]$elements)) { - expanded <- c(expanded, actuals[[i]]$elements) - } else { - if (identical(args[[i]], as.name("...")) && isTRUE(actuals[[i]]$open)) open_dots <- TRUE - expanded <- c(expanded, actuals[i]) - } + dots <- vapply(args, identical, logical(1L), as.name("...")) + if (any(dots)) { + open_dots <- any(dots & vapply(actuals, function(value) is.null(value$elements) && isTRUE(value$open), logical(1L))) + pieces <- lapply(seq_along(args), function(i) { + if (dots[[i]] && !is.null(actuals[[i]]$elements)) return(actuals[[i]]$elements) + actuals[i] + }) + actuals <- unlist(pieces, recursive = FALSE) + if (is.null(actuals)) actuals <- list() } - actuals <- expanded if (open_dots) attr(actuals, "member_open_dots") <- TRUE if (head == "|" && intrinsic(head) && length(actuals) == 2L && isTRUE(member_s7_modes(index)$union)) { classes <- lapply(actuals, function(value) member_s7_spec(value, index, bindings, budget, resolve = FALSE)) diff --git a/R/member-metadata.R b/R/member-metadata.R index b19a90c5..b1af5990 100644 --- a/R/member-metadata.R +++ b/R/member-metadata.R @@ -83,17 +83,17 @@ member_snapshot_dollar_context <- function(lookup_scope) { env = registered, names = ls(registered, all.names = TRUE) ) } - list(scopes = method_scopes, registered = registered) + list(scopes = method_scopes, registered = registered, methods = new.env(parent = emptyenv())) } member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes = list(), - lookup_scope = parent.frame(), dollar_context = NULL) { + lookup_scope = parent.frame(), dollar_context = NULL, function_syntax = member_function_syntax) { seen <- list() remaining <- max_bindings if (is.null(dollar_context)) dollar_context <- member_snapshot_dollar_context(lookup_scope) method_scopes <- dollar_context$scopes registered <- dollar_context$registered - dollar_methods <- new.env(parent = emptyenv()) + dollar_methods <- if (is.null(dollar_context$methods)) new.env(parent = emptyenv()) else dollar_context$methods default_dollar <- function(current) { if (isS4(current) || is.null(registered)) return(FALSE) classes <- attr(current, "class", exact = TRUE) @@ -199,7 +199,7 @@ member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes value <- record[[2L]] field <- if (identical(record[[1L]], "active")) { list( - kind = "active", syntax = if (typeof(value) == "closure") member_function_syntax(value), + kind = "active", syntax = if (typeof(value) == "closure") function_syntax(value), captures = if (typeof(value) == "closure") captures(value) else list() ) } else if (identical(record[[1L]], "value")) { @@ -246,14 +246,14 @@ member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes }) if (!is.null(snapshot)) return(snapshot) if (typeof(value) == "closure") { - syntax <- member_function_syntax(value) + syntax <- function_syntax(value) scope <- environment(value) self <- if (!is.null(r6_receiver) && is.environment(scope)) member_binding(scope, "self") bound <- identical(self[[1L]], "value") && identical(self[[2L]], r6_receiver) && any(vapply(r6_method_scopes(r6_receiver), identical, logical(1L), scope)) contexts <- list() if (bound) { - for (name in intersect(c("private", "super"), member_syntax_names(syntax))) { + for (name in intersect(c("private", "super"), member_syntax_names(member_function_syntax(value)))) { record <- member_binding(scope, name) if (identical(record[[1L]], "value")) { contexts[name] <- list(describe(record[[2L]], depth + 1L, r6_receiver)) diff --git a/R/package-cache.R b/R/package-cache.R index 1ce94024..5f9f02e5 100644 --- a/R/package-cache.R +++ b/R/package-cache.R @@ -35,31 +35,90 @@ package_metadata_identity <- function(package, lib_paths = .libPaths(), context files = package_metadata_file_fingerprint(files), context = context) } +package_metadata_function_signature <- local({ + cache <- NULL + previous <- NULL + function(fn) { + context <- list(syntax = member_function_syntax, formatter = deparse1, + options = lapply(c("digits", "scipen", "deparse.cutoff"), getOption)) + if (is.null(cache) || !identical(context, previous)) { + cache <<- ByteLruCache$new(64 * 1024^2, 4096L) + previous <<- context + } + key <- .Call("member_function_key_c", fn, PACKAGE = "languageserver") + record <- cache$get(key) + arguments <- formals(fn) + code <- body(fn) + if (!is.null(record) && identical(record$arguments, arguments) && identical(record$code, code)) return(record$value) + value <- deparse1(member_function_syntax(fn)) + # Keep syntax, rather than closure environments. Compare it on hits + # even if an evicted/deleted function's address has been reused. + cache$set(key, list(arguments = arguments, code = code, value = value)) + value + } +}) + package_metadata_signature <- function(value) { + if (typeof(value) == "closure") return(package_metadata_function_signature(value)) if (is.call(value) || is.expression(value) || is.pairlist(value)) return(deparse1(value)) if (is.list(value)) return(lapply(value, package_metadata_signature)) value } -package_metadata_namespace_state <- function(ns) { +package_metadata_validation_record <- function(token, name) package_metadata_signature(token) + +# Worker-local validation tokens may contain live function references. Inspect +# mutable bindings on every pass, but normalize only changed facts. Nothing in +# this memo is written to disk or used to execute package/document methods. +package_metadata_validation_records <- local({ + cache <- NULL + function(key, tokens, context, normalize = package_metadata_validation_record) { + if (is.null(cache)) cache <<- ByteLruCache$new(32 * 1024^2, 64L) + if (is.null(tokens)) { + cache$remove(key) + return(NULL) + } + context <- list(inputs = context, normalize = normalize, signature = package_metadata_signature) + previous <- cache$get(key) + if (!identical(previous$context, context)) previous <- NULL + if (!is.null(previous) && identical(previous$tokens, tokens)) return(previous$records) + records <- stats::setNames(lapply(names(tokens), function(name) { + token <- tokens[[name]] + if (!is.null(previous$records[[name]]) && identical(previous$tokens[[name]], token)) return(previous$records[[name]]) + normalize(token, name) + }), names(tokens)) + cache$set(key, list(context = context, tokens = tokens, records = records)) + records + } +}) + +package_metadata_namespace_record <- function(token, name) { + list(name = name, kind = token$kind, + value = digest::digest(package_metadata_signature(token$value), algo = "xxhash64")) +} + +package_metadata_namespace_state <- function(ns, package = unname(getNamespaceName(ns))) { # Cache keys must describe the loaded values too: .onLoad(), tracing and # package reinstalls can change them without changing an export's name. dollar_context <- member_snapshot_dollar_context(ns) modes <- member_s7_capabilities() - records <- lapply(ls(ns, all.names = TRUE), function(name) { - record <- member_binding(ns, name, materialize = TRUE) + materialize <- isNamespace(ns) + binding_names <- ls(ns, all.names = TRUE) + tokens <- stats::setNames(lapply(binding_names, function(name) { + record <- member_binding(ns, name, materialize = materialize) value <- record[[2L]] snapshot <- if (identical(record[[1L]], "value") && !is.object(value) && is.atomic(value) && length(value) <= 256L) { value } else { member_snapshot(value, max_bindings = 50000L, s7_modes = modes, lookup_scope = ns, - dollar_context = dollar_context) + dollar_context = dollar_context, function_syntax = package_metadata_function_signature) } - list(name = name, kind = record[[1L]], value = digest::digest(package_metadata_signature(snapshot), algo = "xxhash64")) - }) - digest::digest(list(bindings = records, subsets = member_subset_registry(ns, unname(getNamespaceName(ns)))), - algo = "xxhash64") + list(kind = record[[1L]], value = snapshot) + }), binding_names) + records <- package_metadata_validation_records(paste0(package, ":members"), tokens, + list(namespace = ns, snapshot = member_snapshot), package_metadata_namespace_record) + digest::digest(list(bindings = unname(records), subsets = member_subset_registry(ns, package)), algo = "xxhash64") } package_metadata_live_identity <- function(package, lib_paths = .libPaths(), context = NULL) { diff --git a/R/s3-metadata.R b/R/s3-metadata.R index a6042a52..b5226c06 100644 --- a/R/s3-metadata.R +++ b/R/s3-metadata.R @@ -329,7 +329,7 @@ s3_metadata_context <- function(packages) { list(kind = record[[1L]], owner = owner, foreign_environment = typeof(value) == "closure" && !isNamespace(environment(value)) && !identical(environment(value), baseenv()), - syntax = if (typeof(value) == "closure") deparse1(member_function_syntax(value)), + syntax = if (typeof(value) == "closure") value, primitive = if (is.primitive(value)) name) }), names) table <- member_binding(ns, ".__S3MethodsTable__.")[[2L]] @@ -342,8 +342,15 @@ s3_metadata_context <- function(packages) { } if (identical(record[[1L]], "value")) s3_runtime_shape(record[[2L]]) }), objects) - list(exports = describe(ns, getNamespaceExports(ns), exported = TRUE), objects = shapes, + tokens <- list(exports = describe(ns, getNamespaceExports(ns), exported = TRUE), objects = shapes, methods = if (is.environment(table) && length(table)) describe(table, ls(table, all.names = TRUE))) + # Section-qualified names keep exported and registered aliases apart. + # Canonical function syntax is reused only while the current binding + # token and owning namespace are unchanged. + stats::setNames(lapply(names(tokens), function(section) { + package_metadata_validation_records(paste(package, "s3", section, sep = ":"), tokens[[section]], + list(namespace = ns, metadata = s3_metadata_context, shapes = s3_runtime_shape)) + }), names(tokens)) }, error = function(e) list(error = conditionMessage(e)))) if (any(vapply(records, function(record) !is.null(record$error), logical(1L)))) return(NULL) digest::digest(records, algo = "xxhash64") diff --git a/inst/benchmarks/README.md b/inst/benchmarks/README.md index da36a169..a36973b0 100644 --- a/inst/benchmarks/README.md +++ b/inst/benchmarks/README.md @@ -44,6 +44,77 @@ workspace startup, metadata worker time and retained cache bytes. Five timing batches capture timer noise; these are local measurements, without timing assertions in the regression suite. +## Persistent package cache validation + +Run `R_LIBS=/path/to/library Rscript --vanilla inst/benchmarks/package-cache.R results.csv 3 polars`. +The optional package argument permits the same comparison with other installed +packages. The script separates first namespace loading, uncached preparation, +cache creation, warm disk hits and loaded-namespace validation. It records CPU +and elapsed time and checks returned metadata; parsing and provider requests are +not included. Run revisions serially with isolated libraries on the same host. + +Validation still inspects mutable namespace bindings and captured values. +Canonical function syntax and unchanged binding facts are reused within a +worker. Syntax memo keys are session-local, body/formals are checked on hits, +and namespace replacement or producer changes invalidate validation facts. +The worker memos are bounded at 64 MiB for syntax and 32 MiB for facts; neither +is a persistent cache of live functions or document state. + +Serial local measurements on R 4.6.1/macOS arm64 with Polars 2.0.0 compared +`da70d5f` with the validation-memo changes (ms; three repeated passes and one cache-creation run): + +| Operation | Before | After | +| --- | ---: | ---: | +| Uncached preparation | 6,830 | 6,744 | +| Cache creation | 7,224 | 6,778 | +| Warm disk hit | 373 | 211 | +| Loaded-namespace validation | 336 | 179 | + +The initial loaded-namespace check remains necessary on every new worker. +Mutable bindings still need inspection; this improvement reuses canonical +syntax and derived facts rather than trusting only a package version or path. + +## Adaptive inference budget + +Run `R_LIBS=/path/to/library Rscript --vanilla inst/benchmarks/member-budget.R results.csv 3`. +Polars metadata is prepared once outside the timer. Each cold run receives the +same metadata and parsed source with fresh receiver, binding and invocation +caches; two repeated requests follow it. Only the budget policy changes: a fixed one-second +elapsed deadline versus the adaptive 250 ms initial allowance, capped at two +seconds of CPU and five seconds elapsed. Policy order alternates between passes. + +Ordinary calls, long chains, wide argument lists, repeated conversions and +recursive code use neutral fixtures. Stalled cases inject 25 or 150 ms at every +inference clock checkpoint to model descheduling. They are controlled local +experiments, not measurements from a remote SSH host. No document expressions, +constructors or methods are executed. CPU/elapsed time, visited nodes, exhausted +budgets, timeout flags and retained results are recorded. Compare cold rows to +isolate the budget policy; warm rows show whether complete results can be reused. +An exhausted or timed-out traversal must not be reported as a fast success. +Completed binding prefixes can survive an exhausted request, allowing its retry +to finish without restarting the entire chain. A final warm request measures +reuse after that retry. Deadline checks occur at bounded traversal checkpoints; +elapsed results can include one checkpoint's overshoot and provider cleanup. + +The same local setup, three passes and identical prepared metadata produced +these cold medians. Ordinary requests remained below the timer's 1 ms +resolution, and normal long chains took 685 ms with the fixed deadline versus +694 ms with the adaptive policy. With 25 ms stalls, the fixed policy stopped +around 1,016 ms on all three cold requests; adaptive analysis completed around +2,363 ms with about 879 ms of CPU work. Repeated +completed requests took approximately 1 ms. With 150 ms stalls, the first +adaptive request stopped around 5,181 ms at the wall limit, a retry reused +completed prefixes and finished around 4,428 ms, and the next request was below +1 ms. The fixed policy continued to time out around 1,070 ms on its third +request. These measurements show the deliberate cold-path tradeoff rather +than a lower latency for every request. + +The 25,000-argument fixture stopped at 20,001 visits (including the exhausted +visit) in 213 ms, down from about 1,513 ms before exhausted argument work and +repeated list copying were removed. Depth-bound and recursive fixtures stopped +in roughly 4 and 14 ms. Regression tests separately cover CPU/wall limits, +explicit caller deadlines, cache invalidation and rejection of partial results. + ## Design and implementation 1. **Remove repeated parse-tree scans.** Native parent/child indexes classify diff --git a/inst/benchmarks/member-budget.R b/inst/benchmarks/member-budget.R new file mode 100644 index 00000000..cfe6c3b2 --- /dev/null +++ b/inst/benchmarks/member-budget.R @@ -0,0 +1,101 @@ +# R_LIBS=/path/to/library Rscript --vanilla inst/benchmarks/member-budget.R results.csv 3 +# Compare time policies using identical prepared metadata and fresh caches. +args <- commandArgs(trailingOnly = TRUE) +output <- if (length(args)) args[[1L]] else "member-budget-performance.csv" +passes <- if (length(args) > 1L) as.integer(args[[2L]]) else 3L +stopifnot(!is.na(passes), passes > 0L) +Sys.setenv(TESTTHAT = "", R_COVR = "", R_PROFILE_USER = "/dev/null", R_ENVIRON_USER = "/dev/null") +benchmark <- new.env(parent = asNamespace("languageserver")) +benchmark$output <- output +benchmark$passes <- passes +evalq({ + run <- function() { + previous <- options(languageserver.package_cache_dir = FALSE) + on.exit(options(previous), add = TRUE) + snapshot <- member_prepare_package("polars") + ns <- asNamespace("languageserver") + original_budget <- member_request_budget + original_infer <- member_infer + replace <- function(name, value) { + unlockBinding(name, ns) + assign(name, value, ns) + lockBinding(name, ns) + } + on.exit({ + replace("member_request_budget", original_budget) + replace("member_infer", original_infer) + }, add = TRUE) + policy <- "adaptive" + stall <- 0 + clock <- function() { + if (stall > 0) Sys.sleep(stall) + base::proc.time() + } + infer <- original_infer + environment(infer) <- list2env(list(proc.time = clock), parent = environment(infer)) + replace("member_infer", infer) + replace("member_request_budget", function() { + budget <- original_budget() + if (policy == "fixed_1s") { + budget$deadline <- budget$started + 1 + budget$scheduled_deadline <- NULL + } + budget + }) + chain <- function(stages) { + c("library(polars)", "item <- as_polars_df(opaque_source())", + rep("item <- item$sort('value')$unique('value')", stages), "item$") + } + workloads <- list( + ordinary = list(lines = c("item <- list(value = 1)", "item$"), stall = 0), + long_chain = list(lines = chain(12L), stall = 0), + contended_chain = list(lines = chain(12L), stall = 0.025), + wall_bound = list(lines = chain(12L), stall = 0.15), + over_budget_chain = list(lines = chain(30L), stall = 0), + wide_conversions = list(lines = c("library(polars)", + paste0("item <- list(", paste(rep("as_polars_df(opaque_source())", 200L), collapse = ","), ")"), "item$"), stall = 0), + node_bound = list(lines = c(paste0("item <- list(", paste(rep("1", 25000L), collapse = ","), ")"), "item$"), stall = 0), + recursive = list(lines = c("factory <- function(x) factory(x)", "item <- factory(opaque_source())", "item$"), stall = 0) + ) + rows <- list() + for (workload in names(workloads)) { + lines <- workloads[[workload]]$lines + parsed <- parse_document("file:///budget-benchmark.R", lines) + for (pass in seq_len(passes)) { + # Alternate order to reduce systematic first-run/JIT bias. + for (selected in if (pass %% 2L) c("fixed_1s", "adaptive") else c("adaptive", "fixed_1s")) { + policy <- selected + stall <- workloads[[workload]]$stall + metadata <- MemberMetadataCache$new(32 * 1024^2) + metadata$set("polars", snapshot) + document <- Document$new("file:///budget-benchmark.R", language = "r", version = 1L, content = lines) + data <- parsed + data$version <- 1L + document$update_parse_data(data) + workspace <- list(member_metadata = metadata) + point <- list(row = length(lines) - 1L, col = nchar(tail(lines, 1L))) + cursor <- member_cursor(document, point) + for (temperature in c("cold", "repeat", "warm")) { + gc() + start <- proc.time() + value <- member_resolve_cursor(document$uri, workspace, document, point, cursor) + elapsed <- proc.time() - start + stopifnot(!is.null(value)) + rows[[length(rows) + 1L]] <- data.frame(workload = workload, policy = policy, pass = pass, + temperature = temperature, elapsed_ms = 1000 * elapsed[[3L]], cpu_ms = 1000 * sum(elapsed[1:2]), + nodes = 20000L - value$budget$remaining, exhausted = isTRUE(value$budget$exhausted), + timed_out = isTRUE(value$budget$timed_out), reason = if (is.null(value$value$reason)) "" else value$value$reason, + receivers = document$member_receivers$size(), bindings = document$member_binding_cache$size()) + } + } + } + } + results <- do.call(rbind, rows) + utils::write.csv(results, output, row.names = FALSE) + print(aggregate(cbind(elapsed_ms, cpu_ms, nodes) ~ workload + policy + temperature, results, stats::median), row.names = FALSE) + print(aggregate(cbind(exhausted, timed_out) ~ workload + policy + temperature, results, sum), row.names = FALSE) + stopifnot(all(results$nodes <= 20001L)) + cat("Metadata preparation/parsing/GC are excluded. Stalled cases inject 25 or 150 ms at each inference clock checkpoint.\n") + } + run() +}, benchmark) diff --git a/inst/benchmarks/package-cache.R b/inst/benchmarks/package-cache.R new file mode 100644 index 00000000..e6d23f4f --- /dev/null +++ b/inst/benchmarks/package-cache.R @@ -0,0 +1,46 @@ +# R_LIBS=/path/to/library Rscript --vanilla inst/benchmarks/package-cache.R results.csv 3 polars +args <- commandArgs(trailingOnly = TRUE) +output <- if (length(args)) args[[1L]] else "package-cache-performance.csv" +passes <- if (length(args) > 1L) as.integer(args[[2L]]) else 3L +package <- if (length(args) > 2L) args[[3L]] else "polars" +stopifnot(!is.na(passes), passes > 0L) +benchmark <- new.env(parent = asNamespace("languageserver")) +benchmark$output <- output +benchmark$passes <- passes +benchmark$package <- package +evalq({ + run <- function() { + directory <- tempfile("package-cache-benchmark-") + dir.create(directory) + on.exit(unlink(directory, recursive = TRUE), add = TRUE) + previous <- options(languageserver.package_cache_dir = FALSE) + on.exit(options(previous), add = TRUE) + measurements <- new.env(parent = emptyenv()) + measurements$rows <- list() + measure <- function(mode, operation, n = passes) { + for (pass in seq_len(n)) { + gc() + start <- proc.time() + value <- operation() + elapsed <- proc.time() - start + stopifnot(is.list(value), is.null(value$error)) + measurements$rows[[length(measurements$rows) + 1L]] <- data.frame(package = package, mode = mode, pass = pass, + elapsed_ms = 1000 * elapsed[[3L]], cpu_ms = 1000 * sum(elapsed[1:2]), + bytes = as.numeric(utils::object.size(value))) + } + } + # The first namespace load is labelled separately. Later rows compare + # preparation, cache creation and hits in the same loaded process. + measure("first_uncached", function() member_prepare_package(package), 1L) + measure("uncached", function() member_prepare_package(package)) + options(languageserver.package_cache_dir = directory) + measure("cache_creation", function() member_prepare_package(package), 1L) + measure("warm_disk_hit", function() member_prepare_package(package)) + measure("namespace_validation", function() package_metadata_live_identity(package)) + results <- do.call(rbind, measurements$rows) + utils::write.csv(results, output, row.names = FALSE) + print(aggregate(cbind(elapsed_ms, cpu_ms) ~ mode, results, stats::median), row.names = FALSE) + cat("R:", as.character(getRversion()), "Package:", as.character(utils::packageVersion(package)), "\n") + } + run() +}, benchmark) diff --git a/src/languageserver.c b/src/languageserver.c index 5ffd64e1..c3e84ca7 100644 --- a/src/languageserver.c +++ b/src/languageserver.c @@ -64,6 +64,7 @@ static const R_CallMethodDef CallEntries[] = { {"completion_select_c", (DL_FUNC) &completion_select_c, 4}, {"member_binding_c", (DL_FUNC) &member_binding_c, 3}, {"member_syntax_names_c", (DL_FUNC) &member_syntax_names_c, 1}, + {"member_function_key_c", (DL_FUNC) &member_function_key_c, 1}, {"source_calls_c", (DL_FUNC) &source_calls_c, 1}, {"syntax_xml_c", (DL_FUNC) &syntax_xml_c, 1}, {"syntax_index_c", (DL_FUNC) &syntax_index_c, 2}, diff --git a/src/member.c b/src/member.c index 53f413ff..3e479870 100644 --- a/src/member.c +++ b/src/member.c @@ -2,8 +2,18 @@ #include #include +#include #include +/* Session-local lookup only. The cache compares body/formals on every hit, + * so address reuse cannot identify a function with different syntax. */ +SEXP member_function_key_c(SEXP fn) { + if (TYPEOF(fn) != CLOSXP) Rf_error("Expected a closure"); + char key[2 + 2 * sizeof(void *) + 1]; + snprintf(key, sizeof(key), "%p", (void *) fn); + return Rf_mkString(key); +} + typedef struct { SEXP *nodes; size_t size, capacity; diff --git a/src/member.h b/src/member.h index 8c8447b6..746dccb0 100644 --- a/src/member.h +++ b/src/member.h @@ -5,5 +5,6 @@ #include SEXP member_syntax_names_c(SEXP expr); +SEXP member_function_key_c(SEXP fn); #endif diff --git a/tests/testthat/test-member-completion.R b/tests/testthat/test-member-completion.R index bdb9f4d1..71fd5a54 100644 --- a/tests/testthat/test-member-completion.R +++ b/tests/testthat/test-member-completion.R @@ -90,7 +90,9 @@ test_that("Static inference notices deadlines that expire during traversal", { expr <- as.call(c(list(as.name("list")), rep(list(1L), 256L))) value <- member_infer(expr, member_generic_index(""), budget = budget) expect_true(budget$exhausted) - expect_identical(tail(value$elements, 1L)[[1L]]$reason, "budget") + expect_identical(value$reason, "budget") + expect_true(budget$timed_out) + expect_gt(budget$remaining, 20000L - length(expr)) }) test_that("Static members propagate through source factories and aliases", { diff --git a/tests/testthat/test-member-reuse-budget.R b/tests/testthat/test-member-reuse-budget.R index bc2b5004..45e122c2 100644 --- a/tests/testthat/test-member-reuse-budget.R +++ b/tests/testthat/test-member-reuse-budget.R @@ -79,6 +79,32 @@ test_that("Adaptive inference still stops at CPU and elapsed limits", { } }) +test_that("Hard adaptive limits apply even before an extended scheduling deadline", { + withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) + budget <- member_request_budget() + budget$deadline <- budget$scheduled_deadline <- budget$started + 3 + expect_true(member_budget_expired(budget, c(budget$cpu_started + 2.1, 0, budget$started + 2.5))) + budget$deadline <- budget$scheduled_deadline <- budget$started + 6 + expect_true(member_budget_expired(budget, c(budget$cpu_started + 0.1, 0, budget$started + 5.1))) + budget$deadline <- budget$started + 10 + expect_false(member_budget_expired(budget, c(budget$cpu_started + 0.1, 0, budget$started + 5.1))) + budget$deadline <- budget$started + 0.1 + expect_true(member_budget_expired(budget, c(budget$cpu_started + 0.01, 0, budget$started + 0.2))) +}) + +test_that("Wide argument lists stop at the shared node budget", { + index <- member_generic_index("") + budget <- member_request_budget() + budget$remaining <- 10L + expr <- as.call(c(list(as.name("list")), rep(list(1), 25000L))) + result <- member_infer(expr, index, budget = budget) + expect_identical(result$reason, "budget") + expect_true(budget$exhausted) + expect_identical(budget$remaining, -1L) + member_infer(quote(list(another = 1)), index, budget = budget) + expect_identical(budget$remaining, -1L) +}) + test_that("S4 inheritance uses the same adaptive allowance and honors explicit deadlines", { withr::local_envvar(c(TESTTHAT = "", R_COVR = "")) timing <- new.env(parent = emptyenv()) diff --git a/tests/testthat/test-package-metadata-cache.R b/tests/testthat/test-package-metadata-cache.R index c5fb4ff4..4488c4bb 100644 --- a/tests/testthat/test-package-metadata-cache.R +++ b/tests/testthat/test-package-metadata-cache.R @@ -162,6 +162,78 @@ test_that("Content fingerprints are reused and detect replacements preserving si expect_identical(computed, 1L) }) +test_that("Namespace validation reuses unchanged canonical facts and inspects mutable bindings", { + ns <- new.env(parent = baseenv()) + ns$target <- function(x) x + environment(ns$target) <- ns + ns$registry <- new.env(parent = emptyenv()) + ns$registry$value <- 1 + captured <- new.env(parent = baseenv()) + captured$kind <- "first" + ns$captured <- function(x) list(kind = kind) + environment(ns$captured) <- captured + getter <- function() { + writeLines("getter", marker) + stop("must not invoke getter") + } + marker <- withr::local_tempfile() + environment(getter) <- list2env(list(marker = marker), parent = baseenv()) + makeActiveBinding("active", getter, ns) + delayedAssign("deferred", stop("must not force promise"), assign.env = ns) + calls <- 0L + normalize <- package_metadata_signature + testthat::local_mocked_bindings(package_metadata_signature = function(value) { + calls <<- calls + 1L + normalize(value) + }, .package = "languageserver") + resolve <- function() package_metadata_namespace_state(ns, "validationfixture") + first <- resolve() + initial <- calls + calls <- 0L + expect_identical(resolve(), first) + expect_identical(calls, 0L) + captured$kind <- "other" + expect_false(identical(resolve(), first)) + expect_gt(calls, 0L) + expect_lt(calls, initial) + previous <- resolve() + ns$registry$value <- 2 + expect_false(identical(resolve(), previous)) + previous <- resolve() + ns$target <- function(revised) revised + environment(ns$target) <- ns + expect_false(identical(resolve(), previous)) + replacement <- new.env(parent = baseenv()) + replacement$target <- ns$target + expect_false(identical(package_metadata_namespace_state(replacement, "validationfixture"), resolve())) + expect_false(file.exists(marker)) +}) + +test_that("Function syntax validation reuses closures and refreshes replacements and formatting", { + calls <- 0L + syntax <- member_function_syntax + testthat::local_mocked_bindings(member_function_syntax = function(fn) { + calls <<- calls + 1L + syntax(fn) + }, .package = "languageserver") + fn <- function(value = 1e5) value + withr::local_options(scipen = 0) + first <- package_metadata_function_signature(fn) + expect_identical(calls, 1L) + expect_identical(package_metadata_function_signature(fn), first) + expect_identical(calls, 1L) + key <- .Call("member_function_key_c", fn, PACKAGE = "languageserver") + replacement <- fn + body(replacement) <- quote(value + 1) + expect_false(identical(.Call("member_function_key_c", replacement, PACKAGE = "languageserver"), key)) + expect_false(identical(package_metadata_function_signature(replacement), first)) + expect_identical(calls, 2L) + withr::local_options(scipen = 999) + expect_false(identical(package_metadata_function_signature(fn), first)) + expect_identical(calls, 3L) + expect_error(.Call("member_function_key_c", quote(value), PACKAGE = "languageserver"), "Expected a closure") +}) + test_that("Loaded namespace changes cannot poison models for another library", { root <- withr::local_tempdir() withr::local_options(languageserver.package_cache_dir = file.path(root, "cache")) @@ -205,7 +277,7 @@ test_that("Loaded namespace changes cannot poison models for another library", { expect_false(identical(package_metadata_help_identity(first_help), package_metadata_help_identity(second_help))) expect_match(get_help(second_help, "text"), "new description", fixed = TRUE) workspace <- Workspace$new(NULL) - expect_match(workspace$get_help("api", package), "old documentation", fixed = TRUE) + expect_match(workspace$get_help("api", package), "old description", fixed = TRUE) # Replace the installed help database without changing the version or # loaded namespace. R's own lazy-load database cache must refresh too. files <- list.files(file.path(second_lib, package, "help"), full.names = TRUE) @@ -219,7 +291,7 @@ test_that("Loaded namespace changes cannot poison models for another library", { file.path(first_lib, package, "Meta/Rd.rds"), overwrite = TRUE)) expect_match(namespace$get_documentation("api")$title, "new documentation", fixed = TRUE) expect_match(namespace$get_documentation("late_topic")$title, "new documentation", fixed = TRUE) - expect_match(workspace$get_help("api", package), "new documentation", fixed = TRUE) + expect_match(workspace$get_help("api", package), "new description", fixed = TRUE) expect_match(get_help(first_help, "text"), "new description", fixed = TRUE) # A same-version, same-size DESCRIPTION replacement changes the general # package identity even when its modification time is preserved. From 1e397454607a682cf4d29a8189d440ff0e5ad727 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Fri, 30 Oct 2026 17:28:33 +0800 Subject: [PATCH 12/12] Unblock constructor requests when member metadata is ready --- R/s3-dispatch.R | 19 +++++++++++++++++ tests/testthat/helper-utils.R | 7 +++++- tests/testthat/test-languagebase.R | 15 +++++++++++++ tests/testthat/test-member-s7.R | 7 +++--- tests/testthat/test-provider-readiness.R | 27 ++++++++++++++++++++++++ 5 files changed, 71 insertions(+), 4 deletions(-) diff --git a/R/s3-dispatch.R b/R/s3-dispatch.R index 204c8294..078f2cda 100644 --- a/R/s3-dispatch.R +++ b/R/s3-dispatch.R @@ -898,6 +898,21 @@ s3_cached_callee <- function(workspace, document, location, packages) { FALSE } +s3_member_constructor_ready <- function(workspace, document, location, packages) { + if (!isTRUE(lsp_settings$get("member_completion")) || !member_symbol_required(workspace, document)) return(FALSE) + metadata <- workspace$member_metadata + if (is.null(metadata) || !is.function(metadata$catalog)) return(FALSE) + required <- if (is.null(location$call$package)) setdiff(packages, startup_packages) else location$call$package + ready <- vapply(required, function(package) { + catalog <- metadata$catalog(package) + !is.null(catalog) && is.null(catalog$error) && !isTRUE(catalog$dataset_only) + }, logical(1L)) + # Missing attached metadata may mask the factory used by a declaration. + if (!all(ready)) return(FALSE) + symbol <- member_constructor_symbol(document$uri, workspace, document, location) + !is.null(symbol$signature) +} + s3_metadata_waiting <- function(self, uri, document, point = NULL, hover = FALSE, call = NULL) { if (!isTRUE(lsp_settings$get("s3_dispatch")) || is.null(self$resolve_task_manager) || !is.function(self$resolve_task_manager$has) || @@ -917,6 +932,10 @@ s3_metadata_waiting <- function(self, uri, document, point = NULL, hover = FALSE if (s3_catalog_ordinary_call(catalog, location$call$token)) return(FALSE) } packages <- s3_call_packages(workspace, document, c(location$point$row, location$point$col)) + # Constructor formals come from member metadata and cannot be refined + # by S3 dispatch catalogs. Share the same verified constructor path as + # signature/hover providers instead of blocking on an unrelated worker. + if (s3_member_constructor_ready(workspace, document, location, packages)) return(FALSE) # Missing S3 catalogs affect method-specific refinement, not an # already-known callable's ordinary signature/help. A missing cached # namespace still blocks this path when it could mask the callee. diff --git a/tests/testthat/helper-utils.R b/tests/testthat/helper-utils.R index e3190e47..dc76c71c 100644 --- a/tests/testthat/helper-utils.R +++ b/tests/testthat/helper-utils.R @@ -163,7 +163,12 @@ respond <- function(client, method, params, timeout, allow_error = FALSE, start_time <- Sys.time() remaining <- timeout - client$deliver(client$request(method, params), callback = cb) + request <- client$request(method, params) + id <- as.character(request$id) + on.exit({ + if (client$request_callbacks$has(id)) client$request_callbacks$remove(id) + }, add = TRUE) + client$deliver(request, callback = cb) if (method == "shutdown") { # do not expect the server returns anything return(NULL) diff --git a/tests/testthat/test-languagebase.R b/tests/testthat/test-languagebase.R index 0d0462b4..26eaa66d 100644 --- a/tests/testthat/test-languagebase.R +++ b/tests/testthat/test-languagebase.R @@ -46,6 +46,21 @@ TestLanguageBase <- R6::R6Class( ) ) +test_that("Timed-out test requests discard callbacks before late replies arrive", { + client <- TestLanguageBase$new() + client$catch_callback_error <- FALSE + expect_failure(respond(client, "textDocument/signatureHelp", NULL, timeout = -1, retry = FALSE), + "timeout when obtaining response") + expect_identical(client$request_callbacks$size(), 0L) + expect_silent(client$handle_response(list(id = 1L, + error = list(code = -32800L, message = "Request superseded by a newer document version")))) + done <- FALSE + request <- client$request("fresh", NULL) + client$deliver(request, callback = function(...) done <<- TRUE) + client$handle_response(list(id = request$id, result = list(ready = TRUE))) + expect_true(done) +}) + test_that("LanguageBase reads fragmented headers and content", { base <- TestLanguageBase$new( lines = list("Content-Length: 2", character(), ""), diff --git a/tests/testthat/test-member-s7.R b/tests/testthat/test-member-s7.R index 767ce2d8..56165d8d 100644 --- a/tests/testthat/test-member-s7.R +++ b/tests/testthat/test-member-s7.R @@ -167,9 +167,10 @@ test_that("S7 constructor and property providers work on first requests after ed uri <- path_to_uri(path) code <- c("library(S7)", "Dog <- new_class(\"Dog\", properties=list(name=class_character, age=class_numeric))", "lola <- Dog(name=\"Lola\", age=11)") did_open(client, path, text = c(code, "lola")) - # Instrumented namespace workers can take over 30 seconds under parallel covr. - # Wait for metadata before checking the first response to each edit. - timeout <- if (identical(Sys.getenv("R_COVR"), "true")) 60 else 10 + # Cold metadata workers share the CI runner with other test servers. This + # barrier prepares the fixture; subsequent edits retain the ordinary + # request timeout and still check their first response without retries. + timeout <- if (identical(Sys.getenv("R_COVR"), "true")) 60 else 30 expected <- "Dog(name = character(0), age = integer(0))" ready <- respond_signature(client, path, c(2L, 12L), timeout = timeout, retry_when = function(result) !identical(result$signatures[[1L]]$label, expected)) diff --git a/tests/testthat/test-provider-readiness.R b/tests/testthat/test-provider-readiness.R index 38ee30b2..66c4c0b0 100644 --- a/tests/testthat/test-provider-readiness.R +++ b/tests/testthat/test-provider-readiness.R @@ -266,6 +266,33 @@ test_that("preparse completion leaves contextual and unmatched names to the curr expect_true(basic_name_completion_reply(4L, fixture$workspace, literate, list(row = 2L, col = 4L), list())$result$isIncomplete) }) +test_that("verified S7 constructors use member readiness independently of S3 catalogs", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + lines <- c("library(S7)", "Dog <- new_class('Dog', properties = list(age = class_numeric))", "Dog(age = )") + fixture <- readiness_fixture(lines) + fixture$document$requested_packages <- list(packages = "S7", namespace_packages = character()) + expect_null(fixture$workspace$s3_metadata$catalog("S7")) + point <- list(row = 2L, col = 10L) + expect_true(s3_metadata_waiting(fixture$server, fixture$uri, fixture$document, point)) + text_document_signature_help(fixture$server, 1L, readiness_params(fixture, 2L, 10L)) + expect_length(fixture$server$replies, 0L) + expect_identical(fixture$server$pending_replies$get(fixture$uri)$`textDocument/signatureHelp`$size(), 1L) + fixture$workspace$member_metadata$set("S7", snapshot) + expect_false(s3_metadata_waiting(fixture$server, fixture$uri, fixture$document, point)) + drained <- drain_pending_replies(fixture$server, fixture$uri, fixture$document$version) + expect_identical(drained$processed, 1L) + expect_length(fixture$server$replies, 1L) + expect_identical(fixture$server$replies[[1L]]$result$signatures[[1L]]$label, "Dog(age = integer(0))") + expect_identical(fixture$server$pending_replies$get(fixture$uri)$`textDocument/signatureHelp`$size(), 0L) + fixture$workspace$member_metadata$remove("S7") + expect_true(s3_metadata_waiting(fixture$server, fixture$uri, fixture$document, point)) + masked <- readiness_fixture(c("library(S7)", "library(pending)", lines[2:3])) + masked$workspace$member_metadata$set("S7", snapshot) + masked$document$requested_packages <- list(packages = c("S7", "pending"), namespace_packages = character()) + expect_true(s3_metadata_waiting(masked$server, masked$uri, masked$document, list(row = 3L, col = 10L))) +}) + test_that("cached but unloaded namespaces still preserve pending masking", { fixture <- readiness_fixture(c("library(masking)", "print()", "masking::print()")) fixture$document$requested_packages <- list(packages = "masking", namespace_packages = "base")