diff --git a/NEWS.md b/NEWS.md index f7b477c8..b1b90131 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,38 @@ # 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. + Retain namespace ownership through chained methods and nested argument + 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 + 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. + +- 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, + 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. Report errors from queued request readiness checks without stopping the server. diff --git a/R/analysis-cache.R b/R/analysis-cache.R new file mode 100644 index 00000000..9ad4a54d --- /dev/null +++ b/R/analysis-cache.R @@ -0,0 +1,75 @@ +# 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]] + 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 +} + +analysis_cache_get <- function(cache, key) { + if (is.null(cache) || is.null(key) || !cache$has(key)) return(list(hit = FALSE)) + 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$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) +} + +# 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) { + 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) + 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 0047afea..12cf2551 100644 --- a/R/document.R +++ b/R/document.R @@ -22,6 +22,8 @@ Document <- R6::R6Class( requested_packages = NULL, member_refresh = FALSE, member_receivers = NULL, + member_binding_cache = NULL, + analysis_caches = NULL, s3_calls = NULL, s3_identity = NULL, member_revision = NULL, @@ -547,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 ) } @@ -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/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 3f4e8435..44591615 100644 --- a/R/member-analysis.R +++ b/R/member-analysis.R @@ -45,6 +45,49 @@ 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) { + 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_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) { @@ -94,8 +137,16 @@ 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))) + } + # 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. @@ -103,9 +154,25 @@ 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)))) } + +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 8a58bda9..ce472c93 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) } @@ -161,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)) @@ -360,6 +368,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 +412,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 +459,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,11 +491,13 @@ 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 } 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) @@ -503,8 +517,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 <- analysis_cache_get(cache, persistent_key) + if (cached$hit) { + value <- cached$value + index$document_cache[[memo_key]] <- value + return(value) + } env <- bindings if (!member_head(item$expr, "function")) env$.__member_position__ <- item$start expr <- item$expr @@ -517,7 +542,13 @@ 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 + if (!is.null(persistent_key) && member_binding_cacheable(cached)) { + analysis_cache_set(cache, persistent_key, cached) + } + } value } @@ -859,13 +890,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, @@ -894,22 +919,32 @@ 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) } } 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 } list(value = value, index = index, bindings = bindings, budget = budget) } @@ -917,6 +952,9 @@ member_resolve_cursor <- function(uri, workspace, document, point, cursor, name 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. @@ -927,10 +965,32 @@ 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 (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) + 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) @@ -938,6 +998,17 @@ member_completion <- function(uri, workspace, document, point, snippet_support, return(NULL) } value <- resolved$value + candidate <- member_possible_receiver(value, resolved$index, resolved$bindings, cursor$accessor) + possible <- !is.null(candidate) + common <- NULL + ambiguous <- character() + if (possible) { + sets <- candidate$sets + common <- candidate$members + if (!length(common)) return(list()) + ambiguous <- candidate$ambiguous + value <- candidate$value + } index <- member_package_context(resolved$index, value$member_package) bindings <- resolved$bindings budget <- resolved$budget @@ -946,6 +1017,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()) @@ -968,8 +1040,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 @@ -978,11 +1055,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, @@ -994,6 +1071,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 a8e584ca..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) { @@ -612,6 +615,13 @@ 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)) { + methods <- names(index$definitions)[startsWith(names(index$definitions), paste0(generic$name, "."))] + add(methods, generic = generic$name) + } } types <- intersect(names(index$members), names(index$classes)) types <- types[order(vapply(index$members[types], length, integer(1L)), types)] @@ -681,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. @@ -689,7 +725,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,15 +743,31 @@ 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 + # 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) + } } - for (item in unfinished) { - if (state$remaining <= 0L || state$bytes >= max_bytes) break - 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 cc6aa382..8656251a 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 } @@ -137,7 +138,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 +157,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 } @@ -212,7 +214,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")) || @@ -306,6 +308,46 @@ 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) +} + +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) { @@ -350,7 +392,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) } @@ -397,6 +439,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")) } @@ -450,11 +500,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]])) { @@ -477,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. @@ -491,10 +546,12 @@ 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")) } infer <- function(x, env = bindings, ctx = context) { @@ -514,10 +571,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) @@ -541,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( @@ -548,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)) { @@ -785,11 +849,22 @@ 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) } + # 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) @@ -850,7 +925,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]] @@ -864,7 +939,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, @@ -1079,7 +1155,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)] @@ -1101,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 = "|") @@ -1125,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)) @@ -1411,6 +1491,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)) } @@ -1429,6 +1523,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 baed9e83..b1af5990 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,7 +83,17 @@ member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes env = registered, names = ls(registered, all.names = TRUE) ) } - dollar_methods <- new.env(parent = emptyenv()) + 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, 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 <- 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) @@ -192,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")) { @@ -239,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)) @@ -486,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() @@ -555,6 +563,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 +586,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 +640,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") } @@ -638,13 +649,28 @@ 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) + if (!identical(record[[1L]], "value") || typeof(record[[2L]]) != "closure" || + !identical(record[[2L]], functions[[method]])) { + 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, @@ -685,9 +711,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, identity = NULL) { .libPaths(lib_paths) ns <- asNamespace(package) + 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)) + }) + 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 +738,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 +749,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_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)) + }) + 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_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/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/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/R/namespace.R b/R/namespace.R index 11edd42c..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,10 +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)) - } + 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, list(context = context, identity = identity, hfile = hfile, value = cached)) + return(cached) + } if (length(hfile) > 0) { doc <- get_help_rd(hfile) @@ -188,7 +197,8 @@ 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/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/package-cache.R b/R/package-cache.R new file mode 100644 index 00000000..5f9f02e5 --- /dev/null +++ b/R/package-cache.R @@ -0,0 +1,347 @@ +# 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)) + list(package = package, path = path, + version = as.character(utils::packageVersion(package, lib.loc = lib_paths)), r = as.character(getRversion()), + 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_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() + 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, function_syntax = package_metadata_function_signature) + } + 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) { + 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 +} + +# 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", + 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_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() { + 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(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(methods) + } else if (package_metadata_server_constant(value)) { + values[name] <- list(value) + } + } + 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(lapply(values, package_metadata_server_syntax), algo = "xxhash64"), + loaded_files = package_metadata_server_load_state$files) + identity + } +}) + +package_metadata_cache_path <- function(type, identity, key = NULL) { + directory <- package_metadata_cache_directory() + if (is.null(directory)) 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 (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 (!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) || 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) + suppressWarnings(Sys.setFileTime(path, Sys.time())) + value + }, error = function(e) NULL) +} + +package_metadata_cache_write <- function(path, identity, value) { + 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({ + directory <- dirname(path) + 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)) { + # 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) > package_metadata_cache_max_bytes] + if (length(expired)) unlink(files[expired]) + }), error = function(e) NULL) + invisible(NULL) +} + +package_metadata_context <- function(packages) { + identities <- lapply(packages, function(package) { + tryCatch(package_metadata_identity(package), error = function(e) list(package = package, error = conditionMessage(e))) + }) + 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-dispatch.R b/R/s3-dispatch.R index 3b4d9988..078f2cda 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) { @@ -840,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) || @@ -859,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. @@ -893,12 +970,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 +994,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 +1011,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/s3-metadata.R b/R/s3-metadata.R index c96a9829..b5226c06 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) @@ -259,10 +261,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 +269,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 +287,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 +315,47 @@ 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, 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, + foreign_environment = typeof(value) == "closure" && !isNamespace(environment(value)) && + !identical(environment(value), baseenv()), + syntax = if (typeof(value) == "closure") value, + primitive = if (is.primitive(value)) name) + }), names) + table <- member_binding(ns, ".__S3MethodsTable__.")[[2L]] + 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) + 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") +} + 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/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/utils.R b/R/utils.R index 4e995f74..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) @@ -600,8 +602,18 @@ 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_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, context = context)) + cached <- package_metadata_cache_read(cache_path, identity, is.character) + if (!is.null(cached)) return(analysis_cache_set(cache, key, cached)) + rd <- get_help_rd(hfile) if (format == "html") { result <- paste0(utils::capture.output( @@ -616,7 +628,10 @@ get_help <- function(hfile, format = c("html", "text")) { stop("Invalid format") } - enc2utf8(result) + result <- enc2utf8(result) + package_metadata_cache_write(cache_path, identity, result) + if (!is.null(identity)) analysis_cache_set(cache, key, result) + result } convert_doc_to_markdown <- function(doc) { diff --git a/R/workspace.R b/R/workspace.R index 7915b4b6..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 ) @@ -182,7 +183,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( @@ -361,6 +362,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, @@ -378,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) { @@ -634,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 { @@ -1127,7 +1131,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 +1150,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/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 9ad8f064..b23958a2 100644 --- a/README.md +++ b/README.md @@ -298,6 +298,52 @@ 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, 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 +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. +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. 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. + +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/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/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-analysis-cache.R b/tests/testthat/test-analysis-cache.R new file mode 100644 index 00000000..38b7be58 --- /dev/null +++ b/tests/testthat/test-analysis-cache.R @@ -0,0 +1,259 @@ +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("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)") + 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) +}) 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-analysis.R b/tests/testthat/test-member-analysis.R index 73497623..9f643a12 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,13 +217,51 @@ 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)) }) +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-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), "")) +}) diff --git a/tests/testthat/test-member-completion.R b/tests/testthat/test-member-completion.R index ca8f55aa..71fd5a54 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,11 +36,16 @@ 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) + 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) @@ -85,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-generic-suggestions.R b/tests/testthat/test-member-generic-suggestions.R new file mode 100644 index 00000000..bf6bf73b --- /dev/null +++ b/tests/testthat/test-member-generic-suggestions.R @@ -0,0 +1,118 @@ +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(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()}", + "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)))" + ), 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"), 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) + 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) + 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("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" + 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-member-return-dispatch.R b/tests/testthat/test-member-return-dispatch.R new file mode 100644 index 00000000..68209a6f --- /dev/null +++ b/tests/testthat/test-member-return-dispatch.R @@ -0,0 +1,50 @@ +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") + 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..45e122c2 --- /dev/null +++ b/tests/testthat/test-member-reuse-budget.R @@ -0,0 +1,195 @@ +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_context = function(...) list(cacheable = TRUE), + package_metadata_live_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("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 + 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("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()) + 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("") + 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("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) + 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 + 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)) +}) 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-package-metadata-cache.R b/tests/testthat/test-package-metadata-cache.R new file mode 100644 index 00000000..4488c4bb --- /dev/null +++ b/tests/testthat/test-package-metadata-cache.R @@ -0,0 +1,390 @@ +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(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)) + 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("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) + 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$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 <- package_metadata_cache_format + record$server$version <- "999.0.0" + saveRDS(record, path) + 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("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")) + 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")) + 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(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) + } + 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") + 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 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) + 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 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. + 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) + 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) + 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", { + 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") + 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")) + 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 new file mode 100644 index 00000000..8be43894 --- /dev/null +++ b/tests/testthat/test-polars-dataframe-completion.R @@ -0,0 +1,106 @@ +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 + remaining <- 128L + testthat::local_mocked_bindings(member_request_budget = function() { + budget <- budget_factory() + budget$remaining <- remaining + 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) + } + } + } + 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"))) + 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) + 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())', + "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) + } +}) 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")