diff --git a/.github/workflows/s7-compatibility.yml b/.github/workflows/s7-compatibility.yml new file mode 100644 index 00000000..b76f4bb3 --- /dev/null +++ b/.github/workflows/s7-compatibility.yml @@ -0,0 +1,50 @@ +name: S7 compatibility + +on: + pull_request: + branches: [master] + push: + branches: [master] + +permissions: read-all + +concurrency: + group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} + cancel-in-progress: true + +jobs: + s7-compatibility: + runs-on: ubuntu-latest + name: S7 (${{ matrix.s7 }}) + strategy: + fail-fast: false + matrix: + s7: [stable, development] + env: + NOT_CRAN: true + TESTTHAT_CPUS: 1 + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v7 + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + use-public-rspm: true + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::remotes + - name: Install stable S7 + if: matrix.s7 == 'stable' + run: remotes::install_version("S7", version = "0.2.2", upgrade = "never") + shell: Rscript {0} + - name: Install pinned S7 1.0 development revision + if: matrix.s7 == 'development' + run: remotes::install_github("RConsortium/S7@021846758e5d4520a56330d477066c25bd46d4f9", upgrade = "never") + shell: Rscript {0} + - name: Install languageserver + run: R CMD INSTALL . + - name: Test member providers + run: | + message("Testing S7 ", packageVersion("S7")) + testthat::test_local(filter = "^member-", load_package = "installed", reporter = "summary") + shell: Rscript {0} diff --git a/DESCRIPTION b/DESCRIPTION index c1f5d9e8..d72184b3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,6 +39,7 @@ Imports: Suggests: covr (>= 3.4.0), magrittr (>= 1.5), + methods, mockery (>= 0.4.2), pacman, processx (>= 3.4.1), @@ -46,6 +47,8 @@ Suggests: testthat (>= 2.1.0), withr (>= 2.3.0), rmarkdown (>= 2.0), + S7, + stats4, stringr ByteCompile: yes Encoding: UTF-8 diff --git a/NEWS.md b/NEWS.md index 98bb8b45..090f6865 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,25 @@ # languageserver 0.3.20 +- Complete chained `$` members using static receiver analysis, including source + list/environment factories, declarative R6 classes and package method + registries. Package metadata is prepared in a background worker; completion + never calls document expressions, constructors, methods or active getters. +- Use the same static member inference for signature help and hover, including + chained methods and named argument documentation. Member requests wait for the + current parse after edits, fixing stale completions on the first `$` trigger. +- Resolve member names across line breaks and infer `self`, `super` and + `private` inside supported R6 methods for completion, hover and signatures. +- Complete S4 `@` slots from source declarations and installed class metadata, + including inheritance, aliases and factory results. Show slot types on hover + and signatures for slots whose function definitions are known statically. +- Complete S7 `@` properties and constructor arguments from source declarations + and installed descriptors, with constructor/property hover and signatures. + Infer inheritance, nested properties and supported custom constructors + without calling constructors, getters, setters, validators or defaults. + Follow installed S7 constructor semantics, including 1.0 development class + references, forwarding constructors, named bindings, list property updates, + external class references, S4 parents and deprecation declarations. + - Run full-document, range, and multiple-range formatting in a lazy, cancellable background worker so other editor requests remain responsive during formatting (#764, #251). - Stabilize diagnostics for Quarto and R Markdown documents by preserving diff --git a/R/capabilities.R b/R/capabilities.R index 1b3ff4aa..82b12b11 100644 --- a/R/capabilities.R +++ b/R/capabilities.R @@ -18,7 +18,7 @@ TextDocumentSyncOptions <- list( CompletionOptions <- list( resolveProvider = TRUE, - triggerCharacters = list(".", ":") + triggerCharacters = list(".", ":", "$", "@") ) SignatureHelpOptions <- list( diff --git a/R/completion.R b/R/completion.R index 2a5330a4..a36383bc 100644 --- a/R/completion.R +++ b/R/completion.R @@ -898,7 +898,7 @@ completion_has_call_parens <- function(document, token_result) { #' The response to a textDocument/completion request #' @noRd completion_reply <- function(id, uri, workspace, document, point, capabilities) { - if (!check_scope(uri, document, point)) { + if (!check_scope(uri, document, point) && is.null(member_cursor(document, point))) { return(Response$new( id, result = list( @@ -911,6 +911,15 @@ completion_reply <- function(id, uri, workspace, document, point, capabilities) snippet_support <- isTRUE(capabilities$completionItem$snippetSupport) && lsp_settings$get("snippet_support") nmax <- lsp_settings$get("max_completions") + if (isTRUE(lsp_settings$get("member_completion"))) { + members <- tryCatch(member_completion(uri, workspace, document, point, + snippet_support, nmax), error = function(e) { + logger$info("static member completion:", e) + NULL + }) + if (!is.null(members)) return(Response$new(id, result = list( + isIncomplete = isTRUE(attr(members, "truncated")), items = unname(members)))) + } token_result <- document$detect_token(point, forward = FALSE) @@ -946,12 +955,15 @@ completion_reply <- function(id, uri, workspace, document, point, capabilities) if (token_result$accessor == "") { call_result <- document$detect_call(point) if (nzchar(call_result$token)) { + constructor_args <- if (isTRUE(lsp_settings$get("member_completion"))) { + member_constructor_arguments(uri, workspace, document, point, token) + } completions <- c( completions, - arg_completion(uri, workspace, point, token, + if (!is.null(constructor_args)) constructor_args else arg_completion(uri, workspace, point, token, call_result$token, call_result$package, exported_only = call_result$accessor != ":::"), - arg_value_completion(uri, workspace, document, point, token, + if (is.null(constructor_args)) arg_value_completion(uri, workspace, document, point, token, call_result$token, call_result$package, exported_only = call_result$accessor != ":::")) } @@ -1006,7 +1018,19 @@ completion_item_resolve_reply <- function(id, workspace, params, capabilities) { resolved <- FALSE if (is.null(params$data) || is.null(params$data$type)) { } else { - if (params$data$type == "package") { + if (params$data$type == "member") { + if (isTRUE(capabilities$completionItem$labelDetailsSupport) && + !is.null(params$data$signature)) params$labelDetails <- list( + detail = substring(params$data$signature, nchar(params$label) + 1L)) + if (!is.null(params$data$package) && is.character(params$data$function_id) && + length(params$data$function_id) == 1L && !is.na(params$data$function_id)) { + doc <- workspace$get_documentation(params$data$function_id, + params$data$package, isf = TRUE, uri = params$data$context_uri) + if (is.list(doc) && !is.null(doc$description)) params$documentation <- list( + kind = "markdown", value = doc$description) + } + resolved <- TRUE + } else if (params$data$type == "package") { if (length(find.package(params$label, quiet = TRUE))) { desc <- utils::packageDescription(params$label, fields = c("Title", "Description")) description <- gsub("\\s*\n\\s*", " ", desc$Description) diff --git a/R/document.R b/R/document.R index f8550f2b..9f7692fe 100644 --- a/R/document.R +++ b/R/document.R @@ -13,6 +13,7 @@ Document <- R6::R6Class( regions = NULL, loaded_packages = NULL, requested_packages = NULL, + member_refresh = FALSE, pending_diagnostics = FALSE, diagnostics_delay = 0, @@ -153,7 +154,8 @@ Document <- R6::R6Class( full_token = result$full_token, package = result$package, accessor = result$accessor, - token = result$token + token = result$token, + opening = list(row = loc[[1L]], col = loc[[2L]]) ) }, @@ -568,6 +570,7 @@ parse_document <- function(uri, content, is_rmarkdown = FALSE, env$xml_data <- NULL env$xml_doc <- NULL env$completion_data <- completion_parse_data(NULL) + env$member_data <- NULL env$semantic_data <- empty_semantic_data() env$range_data <- range_provider_parse_data(NULL, content) env$source_specs <- list() @@ -632,6 +635,7 @@ parse_document <- function(uri, content, is_rmarkdown = FALSE, env$packages <- basename(find.package(env$packages, quiet = TRUE)) data <- utils::getParseData(expr) + env$member_data <- member_document_index(content, expr) env$completion_data <- completion_parse_data(data) env$semantic_data <- semantic_parse_data(data, content) env$range_data <- range_provider_parse_data(data, content) @@ -648,6 +652,7 @@ parse_document <- function(uri, content, is_rmarkdown = FALSE, # Keep the parse version current even while the user is typing an # incomplete expression. Providers can now return an empty result # instead of leaving requests queued until some later valid version. + env$member_data <- member_document_index(content) env$parse_error <- TRUE env$xml_data <- paste0( "\n", @@ -709,8 +714,9 @@ parse_callback <- function(self, uri, version, parse_data) { if (!isTRUE(parse_data$parse_error)) { requested_packages <- normalize_package_request(parse_data$packages) - if (is.null(previous_packages) || + if (is.null(previous_packages) || isTRUE(doc$member_refresh) || !identical(previous_packages, requested_packages)) { + doc$member_refresh <- FALSE doc$requested_packages <- requested_packages self$resolve_task_manager$add_task( uri, @@ -787,6 +793,18 @@ parse_task <- function(self, uri, document, delay = 0) { resolve_callback <- function(self, uri, version, packages) { workspace <- self$get_workspace(uri) if (!workspace$documents$has(uri)) return(NULL) + doc <- workspace$documents$get(uri) + if (!identical(doc$version, version) && + !(is.list(packages) && !is.null(packages$requested) && + identical(doc$requested_packages, packages$requested))) return(NULL) + if (is.list(packages) && !is.null(packages$members)) { + for (package in names(packages$members)) { + snapshot <- packages$members[[package]] + index <- member_index_thaw(snapshot) + if (!is.null(index)) workspace$member_metadata$set(package, as.list(index)) + } + packages <- packages$packages + } logger$info("resolve_callback called:", list(uri = uri, version = version)) workspace$load_packages(packages) doc <- workspace$documents$get(uri) @@ -797,10 +815,12 @@ resolve_callback <- function(self, uri, version, packages) { resolve_task <- function(self, uri, document, packages, delay = 0) { version <- document$version create_task( - target = resolve_attached_packages, - args = list(pkgs = packages), + target = package_call(member_resolve_packages), + args = list(pkgs = packages, lib_paths = .libPaths(), + prepare = isTRUE(lsp_settings$get("member_completion"))), callback = function(result) resolve_callback(self, uri, version, result), error = function(e) logger$info("resolve_task:", e), - delay = 0 + delay = delay, + profiles = FALSE ) } diff --git a/R/handlers-langfeatures.R b/R/handlers-langfeatures.R index abe45dbc..df45bf00 100644 --- a/R/handlers-langfeatures.R +++ b/R/handlers-langfeatures.R @@ -30,6 +30,18 @@ text_document_completion <- function(self, id, params) { document <- workspace$documents$get(uri) if (is.null(document)) return(self$deliver(Response$new(id = id, result = NULL))) point <- document$from_lsp_position(params$position) + # didChange schedules a debounced background parse. A member request can + # arrive immediately after the edit; falling back then uses stale tokens + # and the client keeps that list until another completion is triggered. + if (isTRUE(lsp_settings$get("member_completion")) && + !identical(document$version, document$parse_data$version) && + (!is.null(member_cursor(document, point)) || + !is.null(member_call_location(document, point, symbols = TRUE)))) { + enqueue_latest_reply(self, uri, "textDocument/completion", list( + id = id, version = document$version, params = params + )) + return(invisible(NULL)) + } self$deliver(completion_reply(id, uri, workspace, document, point, self$ClientCapabilities$textDocument$completion)) } @@ -41,6 +53,7 @@ text_document_completion <- function(self, id, params) { completion_item_resolve <- function(self, id, params) { # Resolve uri from completion item if possible uri <- params$data$uri + if (is.null(uri)) uri <- params$data$context_uri if (is.null(uri)) uri <- params$data$textDocument$uri workspace <- self$get_workspace(uri) @@ -60,6 +73,16 @@ text_document_hover <- function(self, id, params) { document <- workspace$documents$get(uri) if (is.null(document)) return(self$deliver(Response$new(id = id, result = NULL))) point <- document$from_lsp_position(params$position) + if (isTRUE(lsp_settings$get("member_completion")) && + !identical(document$version, document$parse_data$version) && + (!is.null(member_hover_location(document, point)) || + !is.null(member_argument_location(document, point, symbols = TRUE)) || + !is.null(member_symbol_location(document, point)))) { + enqueue_latest_reply(self, uri, "textDocument/hover", list( + id = id, version = document$version, params = params + )) + return(invisible(NULL)) + } self$deliver(hover_reply(id, uri, workspace, document, point)) } @@ -75,6 +98,14 @@ text_document_signature_help <- function(self, id, params) { document <- workspace$documents$get(uri) if (is.null(document)) return(self$deliver(Response$new(id = id, result = NULL))) point <- document$from_lsp_position(params$position) + if (isTRUE(lsp_settings$get("member_completion")) && + !identical(document$version, document$parse_data$version) && + !is.null(member_call_location(document, point, symbols = TRUE))) { + enqueue_latest_reply(self, uri, "textDocument/signatureHelp", list( + id = id, version = document$version, params = params + )) + return(invisible(NULL)) + } self$deliver(signature_reply(id, uri, workspace, document, point)) } diff --git a/R/handlers-textsync.R b/R/handlers-textsync.R index b16a6f47..a5e4f802 100644 --- a/R/handlers-textsync.R +++ b/R/handlers-textsync.R @@ -144,6 +144,7 @@ text_document_did_save <- function(self, params) { message = "Request superseded by updated document content") } doc$set_content(doc$version, content) + doc$member_refresh <- isTRUE(lsp_settings$get("member_completion")) doc$did_open() update_document_index( self, workspace, uri, doc$content, cacheable = TRUE) diff --git a/R/hover.R b/R/hover.R index abe11ea3..f1f31c8c 100644 --- a/R/hover.R +++ b/R/hover.R @@ -18,17 +18,20 @@ function_argument_hover_contents <- function(workspace, funct, package, paramete funct, package, isf = TRUE, uri = uri) } if (!is.list(doc)) return(NULL) + sig <- if (is.null(uri)) workspace$get_signature(funct, package) + else call_with_optional_uri( + workspace$get_signature, funct, package, uri = uri) + argument_hover_contents(doc, sig, parameter) +} +argument_hover_contents <- function(doc, sig, parameter) { + if (!is.list(doc)) return(NULL) doc_string <- doc$arguments[[parameter]] if (is.null(doc_string)) { doc_string <- doc$arguments$... parameter <- "..." } if (is.null(doc_string)) return(NULL) - - sig <- if (is.null(uri)) workspace$get_signature(funct, package) - else call_with_optional_uri( - workspace$get_signature, funct, package, uri = uri) if (is.null(sig)) return(doc_string) c( @@ -43,6 +46,18 @@ function_argument_hover_contents <- function(workspace, funct, package, paramete #' if it exists in the current [Workspace]. #' @noRd hover_reply <- function(id, uri, workspace, document, point) { + if (isTRUE(lsp_settings$get("member_completion"))) { + location <- member_hover_location(document, point) + if (is.null(location)) location <- member_argument_location(document, point) + if (!is.null(location)) { + return(member_hover_reply(id, uri, workspace, document, location)) + } + location <- member_argument_location(document, point, symbols = TRUE) + if (is.null(location)) location <- member_symbol_location(document, point) + if (!is.null(member_constructor_symbol(uri, workspace, document, location))) { + return(member_hover_reply(id, uri, workspace, document, location)) + } + } if (!check_scope(uri, document, point)) { return(Response$new(id)) } diff --git a/R/languageserver.R b/R/languageserver.R index 3075fbec..ca5cb519 100644 --- a/R/languageserver.R +++ b/R/languageserver.R @@ -332,6 +332,9 @@ LanguageServer <- R6::R6Class("LanguageServer", diagnostics_delay = delay) { if (!self$pending_replies$has(uri)) { self$pending_replies$set(uri, list( + `textDocument/completion` = collections::queue(), + `textDocument/hover` = collections::queue(), + `textDocument/signatureHelp` = collections::queue(), `textDocument/documentSymbol` = collections::queue(), `textDocument/foldingRange` = collections::queue(), `textDocument/documentLink` = collections::queue(), diff --git a/R/member-completion.R b/R/member-completion.R new file mode 100644 index 00000000..c939b47e --- /dev/null +++ b/R/member-completion.R @@ -0,0 +1,548 @@ +# Document indexes contain syntax and positions, never user values. Recovery +# parses a bounded current expression; earlier statements come from the index. +member_document_index <- function(content, parsed = NULL) { + items <- list() + append <- function(expr, start, end) { + items[[length(items) + 1L]] <<- list(expr = expr, start = start, end = end) + } + if (!is.null(parsed)) { + refs <- attr(parsed, "srcref") + for (i in seq_along(parsed)) { + ref <- refs[[i]] + append(parsed[[i]], c(ref[[1L]] - 1L, ref[[5L]] - 1L), c(ref[[3L]] - 1L, ref[[6L]])) + } + } else { + # Recover complete statements after unrelated syntax errors. Bounds + # apply to incomplete runs; valid large documents use the parser above. + start <- 1L + for (end in seq_along(content)) { + if (end - start > 128L) start <- end + text <- content[seq.int(start, end)] + if (sum(nchar(text, type = "bytes")) > 65536L) { + start <- end + next + } + parsed <- tryCatch(parse(text = text, keep.source = TRUE), error = function(e) NULL) + if (is.null(parsed)) { + # Discard an invalid single line but retain incomplete calls. + message <- tryCatch( + { + parse(text = text) + "" + }, + error = conditionMessage + ) + if (!grepl("unexpected end of input|INCOMPLETE_STRING", message)) start <- end + 1L + next + } + refs <- attr(parsed, "srcref") + for (i in seq_along(parsed)) { + ref <- refs[[i]] + append( + parsed[[i]], c(start + ref[[1L]] - 2L, ref[[5L]] - 1L), + c(start + ref[[3L]] - 2L, ref[[6L]]) + ) + } + start <- end + 1L + } + } + bindings <- new.env(hash = TRUE, parent = emptyenv()) + s4 <- list() + imports <- list() + effects <- list() + for (item in items) { + expr <- item$expr + declaration <- if (member_head(expr, "<-") || member_head(expr, "=")) expr[[3L]] else expr + if (is.call(declaration)) { + head <- declaration[[1L]] + name <- if (member_head(head, "::")) member_name(head[[3L]]) else member_name(head) + args <- as.list(declaration)[-1L] + key <- if ("Class" %in% names(args)) "Class" else if ("name" %in% names(args)) "name" else 1L + class <- if (length(args) && !identical(args[[key]], quote(expr = ))) args[[key]] else NULL + if (!is.null(name) && name %in% c("setClass", "setClassUnion") && + is.character(class) && length(class) == 1L) { + s4[[class]] <- c(s4[[class]], list(item)) + } + } + if (member_head(expr, "<-") || member_head(expr, "=") || member_head(expr, "->") || member_head(expr, ":=")) { + lhs <- if (member_head(expr, "->")) expr[[3L]] else expr[[2L]] + rhs <- if (member_head(expr, "->")) expr[[2L]] else expr[[3L]] + if (member_head(expr, ":=")) rhs <- expr + name <- member_name(lhs) + if (is.null(name) && is.call(lhs)) { + name <- member_name(lhs[[2L]]) + rhs <- quote(.__unknown_mutation__) + } + 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) + assign(name, history, bindings) + } + } + if (member_head(expr, "library") || member_head(expr, "require")) imports[[length(imports) + 1L]] <- item + if (is.call(expr) && !member_head(expr, "<-") && !member_head(expr, "=") && + !member_head(expr, "->") && !member_head(expr, ":=")) { + for (name in member_assigned_names(expr)) { + history <- get0(name, bindings, inherits = FALSE, ifnotfound = list()) + history[[length(history) + 1L]] <- list( + expr = quote(.__unknown_branch_write__), + start = item$start, end = item$end + ) + assign(name, history, bindings) + } + effects[[length(effects) + 1L]] <- item + } + } + list(items = items, bindings = as.list(bindings), imports = imports, effects = effects, s4 = s4) +} + +member_before <- function(a, b) { + a[[1L]] < b[[1L]] || + (a[[1L]] == b[[1L]] && a[[2L]] <= b[[2L]]) +} + +member_cursor <- function(document, point) { + if (!check_r_region(document, point)) { + return(NULL) + } + line <- document$line0(point$row) + prefix <- substr(line, 1L, point$col) + # Include a closing backtick in the replacement when editing a quoted name. + match <- regexec("[$@][ \\t]*(`[^`]*`?|[[:alnum:]_.]*)$", prefix, perl = TRUE)[[1L]] + operator_row <- point$row + accessor <- NULL + if (match[[1L]] < 0L) { + # The member name can start on a later line, with intervening blank + # lines or comments. Recovery still validates the operator in the AST. + match <- regexec("^[ \\t]*(`[^`]*`?|[[:alnum:]_.]*)$", prefix, perl = TRUE)[[1L]] + if (match[[1L]] < 0L) return(NULL) + for (row in seq.int(point$row - 1L, max(0L, point$row - 128L))) { + if (row < 0L || !check_r_region(document, list(row = row, col = 0L))) break + previous <- document$line0(row) + if (grepl("^[ \\t]*(#.*)?$", previous)) next + operator <- regexpr("[$@][ \\t]*(#.*)?$", previous, perl = TRUE)[[1L]] + if (operator > 0L) { + operator_row <- row + accessor <- substr(previous, operator, operator) + } + break + } + if (is.null(accessor)) return(NULL) + } else { + operator <- match[[1L]] + accessor <- substr(prefix, operator, operator) + } + start <- match[[2L]] - 1L + token <- substr(prefix, start + 1L, point$col) + quoted <- startsWith(token, "`") + token <- gsub("^`|`$", "", token) + rest <- substring(line, point$col + 1L) + closed <- quoted && endsWith(substr(prefix, start + 1L, point$col), "`") && point$col > start + 1L + suffix <- regexpr(if (quoted) "^[^`]*`?" else "^[[:alnum:]_.]*", rest, perl = TRUE) + end <- point$col + if (closed) 0L else attr(suffix, "match.length")[[1L]] + # The sentinel must be a member of the cursor's AST, not a string/comment. + list( + operator = operator, operator_row = operator_row, start = start, end = end, token = token, + accessor = accessor, + before = substr(prefix, 1L, start), quoted = quoted + ) +} + +member_recover <- function(document, point, cursor, data) { + content <- if (document$is_rmarkdown) purl(document$content, parseable_only = FALSE) else document$content + content[[point$row + 1L]] <- cursor$before + items <- data$items + # Items are ordered by end position. Avoid scanning a long document on each + # request; only the bounded expression after the preceding item is parsed. + lo <- 1L + hi <- length(items) + preceding <- integer() + while (lo <= hi) { + middle <- as.integer(floor((lo + hi) / 2L)) + if (member_before(items[[middle]]$end, c(cursor$operator_row, cursor$operator - 1L))) { + preceding <- middle + lo <- middle + 1L + } else { + hi <- middle - 1L + } + } + start <- if (length(preceding)) items[[utils::tail(preceding, 1L)]]$end[[1L]] else 0L + start <- max(start, point$row - 128L) + sentinel <- ".__languageserver_member_cursor__" + lines <- content[seq.int(start + 1L, point$row + 1L)] + if (length(preceding)) { + last <- items[[utils::tail(preceding, 1L)]] + if (last$end[[1L]] == start) { + lines[[1L]] <- sub( + "^[ \\t]*;[ \\t]*", "", + substring(lines[[1L]], last$end[[2L]] + 1L) + ) + } + } + if (sum(nchar(lines, type = "bytes")) > 65536L || any(grepl(sentinel, lines, fixed = TRUE))) { + return(NULL) + } + for (skip in seq_len(min(length(lines), 129L))) { + local <- lines[seq.int(skip, length(lines))] + local[[length(local)]] <- paste0(local[[length(local)]], sentinel) + closers <- missing_closing_delimiters(local) + parsed <- tryCatch(parse(text = paste0(paste(local, collapse = "\n"), closers)), error = function(e) NULL) + if (is.null(parsed)) next + found <- FALSE + member_walk(parsed, function(node) { + at_cursor <- if (is.null(cursor$accessor)) { + is.symbol(node) && identical(member_name(node), sentinel) + } else { + member_head(node, cursor$accessor) && identical(member_name(node[[3L]]), sentinel) + } + if (at_cursor) found <<- TRUE + }) + column <- if (skip == 1L && length(preceding) && + items[[utils::tail(preceding, 1L)]]$end[[1L]] == start) { + items[[utils::tail(preceding, 1L)]]$end[[2L]] + } else { + 0L + } + if (found) { + context <- member_recover_context(document, content, point, cursor, start + skip - 1L, column, sentinel, parsed) + return(list( + parsed = parsed, sentinel = sentinel, + context = context, + start = c(start + skip - 1L, column) + )) + } + return(NULL) + } + NULL +} + +member_recover_context <- function(document, content, point, cursor, start, column, sentinel, parsed) { + # Only R6 declarations need later members for method-body context. Stop at + # the first complete declaration, before unrelated trailing syntax errors. + declaration <- FALSE + member_walk(parsed, function(node) { + if (is.call(node) && (identical(member_name(node[[1L]]), "R6Class") || + (member_head(node[[1L]], "::") && identical(member_name(node[[1L]][[3L]]), "R6Class")))) declaration <<- TRUE + }) + if (!declaration) return(NULL) + last <- min(length(content) - 1L, start + 128L) + if (document$is_rmarkdown) { + cell <- literate_r_cell_at(document$regions, point$row) + last <- min(last, cell$body_end - 1L) + } + full <- content[seq.int(start + 1L, last + 1L)] + offset <- point$row - start + 1L + full[[offset]] <- paste0(cursor$before, sentinel, substring(document$line0(point$row), cursor$end + 1L)) + if (column > 0L) full[[1L]] <- sub("^[ \\t]*;[ \\t]*", "", substring(full[[1L]], column + 1L)) + for (end in seq.int(offset, length(full))) { + lines <- full[seq_len(end)] + if (sum(nchar(lines, type = "bytes")) > 65536L) break + context <- tryCatch(parse(text = lines), error = function(e) NULL) + if (!is.null(context)) return(context) + } + NULL +} + +member_context_index <- function(workspace, uri, document, at, parsed = NULL) { + metadata <- if (!is.null(workspace$member_metadata)) workspace$member_metadata else NULL + # Choose the extractor associated with roots actually referenced here. The + # core does not recognize package names, class names, or wrapper conventions. + referenced <- character() + member_walk(parsed, function(node) { + if (is.symbol(node)) referenced <<- c(referenced, as.character(node)) + }) + # Follow a bounded set of referenced assignments (q may have a package + # receiver several aliases back). Do this before choosing an extractor. + seen <- character() + for (pass in seq_len(16L)) { + pending <- setdiff(unique(referenced), seen) + if (!length(pending) || length(seen) > 256L) break + seen <- c(seen, pending) + for (name in pending) { + history <- document$parse_data$member_data$bindings[[name]] + for (item in utils::tail(history, 1L)) { + member_walk(item$expr, function(node) { + if (is.symbol(node)) referenced <<- c(referenced, as.character(node)) + }) + } + } + } + index <- member_generic_index("") + if (!is.null(metadata)) { + for (package in metadata$keys()) { + candidate <- metadata$get(package) + if (length(intersect(referenced, c(names(candidate$roots), candidate$exports))) || package %in% referenced) { + index <- list2env(as.list(candidate), parent = emptyenv()) + break + } + } + } + index$document_bindings <- document$parse_data$member_data$bindings + index$methods_attached <- TRUE + index$attached_roots <- list() + index$attached_s4 <- list() + index$document_s4 <- document$parse_data$member_data$s4 + index$namespace_indices <- list() + index$s4_dependencies <- list() + if (!is.null(metadata)) { + for (package in metadata$keys()) { + package_index <- metadata$get(package) + index$namespace_indices[package] <- list(package_index) + for (dependency in names(package_index$s7_dependencies)) { + if (!is.null(index$namespace_indices[[dependency]])) next + index$namespace_indices[dependency] <- package_index$s7_dependencies[dependency] + } + if (!is.null(package_index$s4_dependencies)) { + index$s4_dependencies <- utils::modifyList(index$s4_dependencies, package_index$s4_dependencies) + } + for (name in names(package_index$namespace_roots)) index$namespace_roots[name] <- list(package_index$namespace_roots[[name]]) + } + } + data <- document$parse_data$member_data + if (is.null(data)) { + return(index) + } + for (item in data$imports) { + if (!member_before(item$end, at)) next + expr <- item$expr + if (member_head(expr, "library") || member_head(expr, "require")) { + package <- member_name(expr[[2L]]) + if (!is.null(package) && package %in% names(index$namespace_indices)) { + index$attached_roots <- utils::modifyList(index$attached_roots, index$namespace_indices[[package]]$roots) + package_index <- index$namespace_indices[[package]] + if (!is.null(package_index$s4_classes)) { + index$attached_s4 <- utils::modifyList(index$attached_s4, package_index$s4_classes) + } + for (name in intersect(package_index$exports, names(package_index$definitions))) { + if (member_head(package_index$definitions[[name]], "function") && + is.null(index$attached_roots[[name]]$s4_generator) && + is.null(index$attached_roots[[name]]$s7_generator)) { + index$attached_roots[name] <- list(member_value(function_key = name, metadata = package)) + } + } + } + if (identical(package, "R6")) index$r6_attached <- TRUE + if (identical(package, "S7")) index$s7_attached <- TRUE + } + } + index +} + +member_resolve_document <- function(name, index, bindings, budget, depth, trail) { + if (depth > 64L) return(member_value(reason = "binding_recursion")) + history <- index$document_bindings[[name]] + at <- bindings$.__member_position__ + if (is.null(at)) at <- c(Inf, Inf) + candidates <- which(vapply(history, function(item) member_before(item$end, at), logical(1L))) + if (!length(candidates)) { + return(if (is.null(index$attached_roots[[name]])) { + member_value(reason = "not_yet_bound") + } else { + index$attached_roots[[name]] + }) + } + position <- utils::tail(candidates, 1L) + item <- history[[position]] + id <- paste0("binding:", name, ":", position) + if (id %in% trail) { + return(member_value(reason = "binding_cycle")) + } + env <- bindings + if (!member_head(item$expr, "function")) env$.__member_position__ <- item$start + expr <- item$expr + if (member_head(expr, ":=")) { + bound <- member_s7_bind(expr, index, env) + if (is.null(bound)) return(member_resolve_document(name, index, env, budget, depth + 1L, c(trail, id))) + expr <- bound[[3L]] + } + value <- member_infer(expr, index, env, + depth = depth + 1L, + trail = c(trail, id), budget = budget + ) + value +} + +member_cursor_value <- function(parsed, sentinel, index, bindings, budget, name = NULL, accessor = "$", context = NULL) { + result <- NULL + has_cursor <- function(node) { + found <- FALSE + member_walk(node, function(child) { + if (member_head(child, accessor) && identical(member_name(child[[3L]]), sentinel)) found <<- TRUE + }) + found + } + visit <- function(node, env) { + if (is.null(accessor) && is.symbol(node) && identical(member_name(node), sentinel)) { + result <<- member_infer(as.name(name), index, env, budget = budget) + return(invisible(NULL)) + } + if (!is.call(node) && !is.expression(node)) { + return(invisible(NULL)) + } + if (is.null(accessor) && member_head(node, "::") && identical(member_name(node[[3L]]), sentinel)) { + node[[3L]] <- as.name(name) + result <<- member_infer(node, index, env, budget = budget) + return(invisible(NULL)) + } + if (member_head(node, accessor) && identical(member_name(node[[3L]]), sentinel)) { + if (is.null(name)) { + result <<- member_infer(node[[2L]], index, env, budget = budget) + } else { + receiver <- member_infer(node[[2L]], index, env, budget = budget) + env$.__member_receiver__ <- receiver + node[[2L]] <- as.name(".__member_receiver__") + node[[3L]] <- as.name(name) + result <<- member_infer(node, index, env, budget = budget) + key <- member_members(receiver, index, env, accessor)[name] + if (is.null(result$function_key) && length(key) && !is.na(key[[1L]]) && + !is.null(result$function_expr)) { + result$function_key <<- key[[1L]] + } + } + return(invisible(NULL)) + } + if (member_head(node, "function")) { + for (name in names(node[[2L]])) env[name] <- list(member_value(reason = "formal")) + visit(node[[3L]], env) + return(invisible(NULL)) + } + if (member_is_r6_call(node, index, env) && has_cursor(node)) { + scope <- member_r6_context(node, index, env, budget) + args <- as.list(node)[-1L] + for (section in c("public", "private", "active")) { + if (!member_head(args[[section]], "list")) next + for (method in as.list(args[[section]])[-1L]) { + if (member_head(method, "function") && has_cursor(method)) visit(method, utils::modifyList(env, scope)) + } + } + return(invisible(NULL)) + } + if (member_head(node, "{") || is.expression(node)) { + children <- if (is.expression(node)) as.list(node) else as.list(node)[-1L] + for (child in children) { + if (member_head(child, ":=")) { + bound <- member_s7_bind(child, index, env) + if (!is.null(bound)) child <- bound + } + env <- member_s4_effect(child, index, env) + visit(child, env) + if (!is.null(result)) break + if ((member_head(child, "<-") || member_head(child, "=")) && is.symbol(child[[2L]])) { + env[as.character(child[[2L]])] <- list(member_infer(child[[3L]], index, env, budget = budget)) + } else { + for (name in member_assigned_names(child)) env[name] <- list(member_value(reason = "unknown_local_write")) + } + } + } else { + # A member can be the callee of a call in the complete context. + for (child in as.list(node)) visit(child, env) + } + invisible(NULL) + } + visit(if (is.null(context)) parsed else context, bindings) + result +} + +member_resolve_cursor <- function(uri, workspace, document, point, cursor, name = NULL) { + if (!identical(document$version, document$parse_data$version) && + !is.null(document$parse_data$version)) { + return(NULL) + } + if (is.null(cursor)) { + return(NULL) + } + data <- document$parse_data$member_data + if (is.null(data)) { + return(NULL) + } + recovered <- member_recover(document, point, cursor, data) + if (is.null(recovered)) { + return(NULL) + } + index <- member_context_index(workspace, uri, document, recovered$start, recovered$parsed) + budget <- new.env(parent = emptyenv()) + budget$remaining <- 20000L + budget$exhausted <- budget$transient <- FALSE + # Coverage rewrites byte-compiled functions and adds counters to every + # branch. Allow that overhead while retaining node, depth and time bounds. + budget$time_limit <- if (identical(Sys.getenv("R_COVR"), "true")) 10 else 0.25 + bindings <- list(.__member_position__ = recovered$start) + if (length(index$registration_rules)) { + for (item in data$effects) { + if (!member_before(item$end, recovered$start)) next + env <- bindings + env$.__member_position__ <- item$start + bindings <- member_registration_effect(item$expr, index, env) + } + } + bindings$.__member_position__ <- recovered$start + value <- member_cursor_value(recovered$parsed, recovered$sentinel, index, bindings, budget, name, cursor$accessor, recovered$context) + list(value = value, index = index, bindings = bindings, budget = budget) +} + +member_completion <- function(uri, workspace, document, point, snippet_support, limit) { + cursor <- member_cursor(document, point) + resolved <- member_resolve_cursor(uri, workspace, document, point, cursor) + if (is.null(resolved)) { + return(NULL) + } + value <- resolved$value + index <- resolved$index + bindings <- resolved$bindings + budget <- resolved$budget + if (is.null(value) || !length(value$type)) { + return(NULL) + } + members <- member_members(value, index, bindings, cursor$accessor) + labels <- as.character(names(members)) + if (!length(labels)) { + return(list()) + } + # Filter before pruning so unrelated labels cannot consume the limit. + matches <- sort(labels[fuzzy_find(labels, cursor$token)]) + keep <- completion_select_indices(matches, matches, cursor$token, limit) + labels <- matches + labels <- labels[keep] + items <- lapply(labels, function(label) { + shape <- if (identical(cursor$accessor, "@")) { + member_slot(value, label, index, bindings, budget) + } else { + value$fields[[label]] + } + key <- members[[label]] + symbol <- member_symbol_info(label, shape, key, index) + is_function <- !is.null(shape$function_expr) || !is.null(shape$result_shape) || + !is.null(shape$function_key) || (!is.null(key) && !is.na(key)) + inserted <- if (identical(make.names(label), label) && !label %in% c("TRUE", "FALSE", "NULL", "NA")) { + label + } else { + paste0("`", gsub("`", "\\`", gsub("\\", "\\\\", label, fixed = TRUE), fixed = TRUE), "`") + } + following <- substring(document$line0(point$row), cursor$end + 1L) + snippet <- is_function && snippet_support && !startsWith(trimws(following), "(") + text <- if (snippet) paste0(gsub("[$}]", "\\\\&", inserted), "($0)") else inserted + signature <- symbol$signature + documentation_id <- symbol$function_id + list( + label = label, kind = if (is_function) CompletionItemKind$Method else CompletionItemKind$Field, + detail = if (!is.null(signature)) { + signature + } else if (identical(cursor$accessor, "@")) { + paste0(label, ": ", paste(value$slot_types[[label]], collapse = " | ")) + } else { + "[static member]" + }, sortText = label, + filterText = label, insertTextFormat = if (snippet) InsertTextFormat$Snippet else InsertTextFormat$PlainText, + textEdit = text_edit(range( + document$to_lsp_position(point$row, cursor$start), + document$to_lsp_position(point$row, cursor$end) + ), text), + data = list( + type = "member", package = symbol$package, function_id = documentation_id, + signature = signature, context_uri = uri, generation = index$generation + ) + ) + }) + if (length(matches) > limit || budget$exhausted) attr(items, "truncated") <- TRUE + items +} diff --git a/R/member-extraction.R b/R/member-extraction.R new file mode 100644 index 00000000..f7e5820e --- /dev/null +++ b/R/member-extraction.R @@ -0,0 +1,562 @@ +# Package-independent extraction of declarative constructors and registry dispatch. +# Every name and relation below comes from syntax or inert namespace bindings. + +member_data <- function(node, constants = list(), depth = 0L) { + if (depth > 12L || missing(node)) { + return(NULL) + } + if (is.atomic(node)) { + return(node) + } + if (is.symbol(node)) { + return(constants[[as.character(node)]]) + } + if (!is.call(node)) { + return(NULL) + } + head <- member_name(node[[1L]]) + if (is.null(head)) { + return(NULL) + } + if (!head %in% c("c", "setdiff", "names")) { + return(NULL) + } + args <- as.list(node)[-1L] + values <- lapply(args, member_data, constants, depth + 1L) + if (head == "c" && all(vapply(values, function(x) !is.null(x), logical(1L)))) { + return(unlist(values)) + } + if (head == "setdiff" && length(values) == 2L && all(vapply(values, function(x) !is.null(x), logical(1L)))) { + return(setdiff(values[[1L]], values[[2L]])) + } + if (head == "names" && length(args) == 1L && is.symbol(args[[1L]])) { + return(names(constants[[as.character(args[[1L]])]])) + } + NULL +} + +member_constructor <- function(fn) { + if (!member_head(fn, "function")) { + return(NULL) + } + body <- fn[[3L]] + if (!member_head(body, "{")) { + return(NULL) + } + statements <- as.list(body)[-1L] + last <- statements[[length(statements)]] + if (member_head(last, "return") && length(last) == 2L) last <- last[[2L]] + target <- member_name(last) + if (is.null(target)) { + return(NULL) + } + classes <- NULL + fields <- list() + aliases <- list() + created <- FALSE + for (node in statements) { + if (member_head(node, "<-") && is.symbol(node[[2L]])) { + aliases[as.character(node[[2L]])] <- list(node[[3L]]) + if (identical(member_name(node[[2L]]), target) && member_head(node[[3L]], "new.env")) created <- TRUE + } + if (member_head(node, "<-") && member_head(node[[2L]], "class") && + identical(member_name(node[[2L]][[2L]]), target)) { + classes <- member_strings(node[[3L]]) + # Native-dependent subclasses precede a literal base-class suffix. + # Retain that guaranteed suffix without inventing a subtype. + if (!length(classes) && member_head(node[[3L]], "c")) { + parts <- as.list(node[[3L]])[-1L] + literal <- vapply(parts, is.character, logical(1L)) + last_dynamic <- max(c(0L, which(!literal))) + if (last_dynamic < length(parts)) classes <- unlist(parts[seq.int(last_dynamic + 1L, length(parts))]) + } + } + if (member_head(node, "<-") && member_head(node[[2L]], "$") && + identical(member_name(node[[2L]][[2L]]), target)) { + name <- member_name(node[[2L]][[3L]]) + rhs <- node[[3L]] + if (is.symbol(rhs) && !is.null(aliases[[as.character(rhs)]])) rhs <- aliases[[as.character(rhs)]] + fields[name] <- list(list(expr = rhs, active = FALSE)) + } + if (member_head(node, "makeActiveBinding") && length(node) >= 4L && + identical(member_name(node[[4L]]), target)) { + name <- member_strings(node[[2L]]) + if (length(name) == 1L) fields[name] <- list(list(expr = node[[3L]], active = TRUE)) + } + } + # Conditional fields and computed class vectors are not unconditional + # constructor guarantees. Only literal top-level declarations qualify. + if (!created || !length(classes)) { + return(NULL) + } + list(type = classes[[1L]], classes = classes, fields = fields, body = body, target = target) +} + + +member_definition <- function(definitions, key) { + seen <- character() + while (is.symbol(member_lookup(definitions, key))) { + if (key %in% seen) { + return(NULL) + } + seen <- c(seen, key) + key <- as.character(definitions[[key]]) + } + member_lookup(definitions, key) +} + +member_returned_function <- function(fn) { + if (!member_head(fn, "function")) { + return(NULL) + } + body <- fn[[3L]] + statements <- if (member_head(body, "{")) as.list(body)[-1L] else list(body) + if (!length(statements)) { + return(NULL) + } + last <- utils::tail(statements, 1L)[[1L]] + if (member_head(last, "return") && length(last) == 2L) last <- last[[2L]] + if (member_head(last, "function")) { + return(list(fn = last, prelude = statements[-length(statements)])) + } + if (!is.symbol(last)) { + return(NULL) + } + target <- as.character(last) + returned <- NULL + copied <- NULL + prelude <- list() + for (node in statements[-length(statements)]) { + if (member_head(node, "<-") && identical(member_name(node[[2L]]), target) && + member_head(node[[3L]], "function")) { + returned <- node[[3L]] + } else if (member_head(node, "<-") && member_head(node[[2L]], "formals") && + identical(member_name(node[[2L]][[2L]]), target) && member_head(node[[3L]], "formals")) { + copied <- member_name(node[[3L]][[2L]]) + } else if (is.null(returned)) prelude[[length(prelude) + 1L]] <- node + } + if (is.null(returned)) { + return(NULL) + } + list(fn = returned, prelude = prelude, copied = copied) +} + +member_source_registries <- function(input) { + definitions <- input$definitions + registries <- list() + for (key in names(definitions)) { + if (member_head(definitions[[key]], "new.env")) registries[key] <- list(character()) + } + for (key in names(definitions)) { + parts <- strsplit(key, "$", fixed = TRUE)[[1L]] + if (length(parts) == 2L && parts[[1L]] %in% names(registries)) { + registries[[parts[[1L]]]][parts[[2L]]] <- key + } + } + # Validate the source population recipe before interpreting a literal + # prefix-to-environment map. An unrelated named list is not a registry. + collectors <- character() + for (key in names(definitions)) { + fn <- definitions[[key]] + if (!member_head(fn, "function") || length(fn[[2L]]) < 2L) next + args <- names(fn[[2L]]) + enumerates <- strips <- assigns <- FALSE + member_walk(fn[[3L]], function(node) { + if (member_head(node, "ls") && identical(member_name(as.list(node)$pattern), args[[2L]])) enumerates <<- TRUE + if (member_head(node, "sub") && length(node) >= 4L && + identical(member_name(node[[2L]]), args[[2L]]) && identical(node[[3L]], "")) { + strips <<- TRUE + } + if (member_head(node, "assign") && identical(member_name(as.list(node)$envir), args[[1L]])) assigns <<- TRUE + }) + if (enumerates && strips && assigns) collectors <- c(collectors, key) + } + maps <- character() + for (code in input$expressions) { + member_walk(code, function(node) { + if (!is.call(node) || length(node) < 3L) { + return() + } + key <- member_name(node[[1L]]) + if (is.null(key) || !key %in% collectors) { + return() + } + destination <- node[[2L]] + pattern <- node[[3L]] + if (!member_head(destination, "[[") || !member_head(pattern, "sprintf") || + length(pattern) != 3L || !identical(pattern[[2L]], "^%s") || + !identical(destination[[3L]], pattern[[3L]])) { + return() + } + map <- member_name(destination[[2L]]) + if (!is.null(map)) maps <<- union(maps, map) + }) + } + for (map in maps) { + node <- definitions[[map]] + if (!member_head(node, "list")) next + entries <- as.list(node)[-1L] + for (prefix in names(entries)) { + registry <- member_name(entries[[prefix]]) + if (is.null(registry) || !registry %in% names(registries) || !nzchar(prefix)) next + keys <- names(definitions)[startsWith(names(definitions), prefix)] + registries[[registry]] <- c( + registries[[registry]], + stats::setNames(keys, substring(keys, nchar(prefix) + 1L)) + ) + } + } + registries +} + +member_package_index <- function(input) { + index <- member_generic_index("") + index$package <- input$package + index$definitions <- input$definitions + index$locations <- input$locations + index$exports <- input$exports + index$registries <- if (!is.null(input$registries)) input$registries else member_source_registries(input) + index$intrinsics <- if (!is.null(input$intrinsics)) input$intrinsics else character() + index$nonreturning_functions <- intersect(c("stop", "abort"), c(member_base_intrinsics, index$intrinsics)) + index$package_roots <- list() + index$constructor_inputs <- list() + index$namespace_owners <- list() + index$delegation <- list() + index$method_receivers <- list() + index$methods_attached <- FALSE + index$s4_classes <- if (is.null(input$s4_classes)) list() else input$s4_classes + index$s4_dependencies <- input$s4_dependencies + index$s7_capabilities <- input$s7_capabilities + index$s7_dependencies <- input$s7_dependencies + index$s7_attached <- identical(input$package, "S7") + for (name in names(input$s7_roots)) index$package_roots[name] <- input$s7_roots[name] + declarations <- list() + for (code in input$expressions) { + for (node in code) declarations <- member_s4_effect(node, index, declarations) + } + if (!is.null(declarations$.__s4_classes__)) { + index$s4_classes <- utils::modifyList(index$s4_classes, declarations$.__s4_classes__) + } + constants <- index$registries + for (key in names(index$definitions)) { + node <- index$definitions[[key]] + literal <- member_data(node, constants) + if (!is.null(literal)) constants[key] <- list(literal) + # S7 class declarations expose literal properties without constructing + # an instance. Accept only a verified imported descriptor constructor. + if (member_head(node, "new_class") && "new_class" %in% index$intrinsics) { + type <- member_strings(node[[2L]]) + properties <- as.list(node)$properties + if (length(type) == 1L && member_head(properties, "list")) { + fields <- names(as.list(properties)[-1L]) + index$constructor_types[key] <- list(type) + index$classes[type] <- list(type) + index$members[type] <- list(stats::setNames(rep(NA_character_, length(fields)), fields)) + } + } + ctor <- member_constructor(node) + if (is.null(ctor)) next + index$constructors[key] <- list(ctor) + index$classes[ctor$type] <- list(ctor$classes) + fields <- names(ctor$fields) + index$members[ctor$type] <- list(stats::setNames(rep(NA_character_, length(fields)), fields)) + # Constructor-installed bound closures are inferred from the assignment + # RHS, regardless of native generator, class or factory naming scheme. + for (field in fields) { + recipe <- ctor$fields[[field]] + factory <- if (is.call(recipe$expr)) member_key(recipe$expr[[1L]]) else NULL + returned <- member_returned_function(member_definition(index$definitions, factory)) + if (!is.null(returned) && is.null(returned$copied)) { + index$native_factories <- unique(c(index$native_factories, factory)) + index$members[[ctor$type]][field] <- factory + } + } + } + for (key in names(input$descriptors)) { + descriptor <- input$descriptors[[key]] + index$constructor_types[key] <- list(descriptor$type) + index$classes[descriptor$type] <- list(descriptor$type) + old <- index$members[[descriptor$type]] + fields <- setdiff(descriptor$fields, names(old)) + index$members[descriptor$type] <- list(c(old, stats::setNames(rep(NA_character_, length(fields)), fields))) + } + # UseMethod and standard S3 method IDs supply input-class constraints for + # constructors. Multiple generics can share a class without a global wrap map. + for (key in names(index$definitions)) { + node <- index$definitions[[key]] + if (!member_head(node, "function")) next + generic <- NULL + member_walk(node[[3L]], function(child) { + if (member_head(child, "UseMethod")) generic <<- member_strings(child[[2L]]) + }, descend_functions = FALSE) + if (length(generic) != 1L) next + constructor_names <- as.character(names(index$constructors)) + for (method in constructor_names[startsWith(constructor_names, paste0(generic, "."))]) { + formal <- names(index$definitions[[method]][[2L]])[[1L]] + index$constructor_inputs[[method]][formal] <- list(member_value(type = substring(method, nchar(generic) + 2L))) + } + } + for (registry in names(index$registries)) { + index$members[registry] <- list(index$registries[[registry]]) + index$package_roots[registry] <- list(member_value(type = registry)) + } + for (registry in names(index$registries)) { + for (field in names(index$registries[[registry]])) { + key <- index$registries[[registry]][[field]] + if (key %in% names(index$package_roots)) { + index$members[[registry]][field] <- NA_character_ + index$properties[[registry]][field] <- list(index$package_roots[[key]]) + } + } + } + # Every ordinary environment surface is discovered, including static bundles + # and exported roots. Active names are retained but getters are only analyzed. + for (name in names(input$snapshots)) { + snapshot <- input$snapshots[[name]] + shape <- member_snapshot_shape(snapshot) + shape$type <- name + for (field in names(index$registries[[name]])) { + if (is.null(shape$fields[[field]]$s7_generator)) { + shape$fields[field] <- list(member_value(function_key = index$registries[[name]][[field]])) + } + } + for (field in names(input$links[[name]])) shape$fields[field] <- list(member_value(type = input$links[[name]][[field]])) + index$package_roots[name] <- list(shape) + for (field in names(snapshot$fields)) { + if (!field %in% names(index$members[[name]])) index$members[[name]][field] <- NA_character_ + } + } + # Registry lookup branches describe membership, precedence, lexical receiver + # rebinding, returned method factories and delegation through closure factories. + definition_names <- as.character(names(index$definitions)) + for (key in definition_names[startsWith(definition_names, "$.")]) { + fn <- index$definitions[[key]] + if (!member_head(fn, "function")) next + type <- substring(key, 3L) + formals <- names(fn[[2L]]) + if (length(formals) < 2L) next + locals <- constants + member_walk(fn[[3L]], function(node) { + if (member_head(node, "<-") && is.symbol(node[[2L]])) { + value <- member_data(node[[3L]], locals) + if (!is.null(value)) locals[as.character(node[[2L]])] <<- list(value) + } + }, descend_functions = FALSE) + members <- character() + inspect <- function(node) { + if (!is.call(node)) { + return(invisible(NULL)) + } + if (member_head(node, "if")) { + condition <- node[[2L]] + allowed <- if (member_head(condition, "%in%") && + identical(member_name(condition[[2L]]), formals[[2L]])) { + member_data(condition[[3L]], locals) + } else { + NULL + } + branch <- node[[3L]] + registry <- variable <- receiver_name <- NULL + factory_call <- NULL + bound_factory <- FALSE + member_walk(branch, function(child) { + if (!is.call(child)) { + return() + } + if (member_head(child, "[[") && member_name(child[[2L]]) %in% names(index$registries) && + identical(member_name(child[[3L]]), formals[[2L]])) { + registry <<- member_name(child[[2L]]) + } + if (member_head(child, "<-") && member_head(child[[3L]], "[[")) variable <<- member_name(child[[2L]]) + if (member_head(child, "<-") && identical(member_name(child[[3L]]), formals[[1L]])) receiver_name <<- member_name(child[[2L]]) + if (is.call(child[[1L]]) && member_head(child[[1L]], "[[")) bound_factory <<- TRUE + returned <- member_returned_function(member_definition(index$definitions, member_key(child[[1L]]))) + if (!is.null(returned) && !is.null(returned$copied)) factory_call <<- child + }, descend_functions = FALSE) + if (!is.null(registry) && !is.null(allowed)) { + values <- index$registries[[registry]][intersect(allowed, names(index$registries[[registry]]))] + for (name in names(values)) { + original_key <- values[[name]] + if (bound_factory) index$native_factories <- unique(c(index$native_factories, original_key)) + if (!is.null(receiver_name)) index$method_receivers[[paste(type, original_key, sep = "|")]] <- receiver_name + if (!is.null(factory_call)) { + factory_key <- member_key(factory_call[[1L]]) + wrapper <- member_definition(index$definitions, factory_key) + returned <- member_returned_function(wrapper) + original <- member_definition(index$definitions, original_key) + if (!member_head(original, "function")) next + derived <- paste0(".delegated:", type, ":", name) + index$definitions[derived] <- list(as.call(list(as.name("function"), original[[2L]], returned$fn[[3L]]))) + args <- as.list(factory_call)[-1L] + # Bind syntax arguments to factory formals, substituting + # the dispatch receiver and the selected original method. + captures <- list() + for (i in seq_along(args)) { + formal <- if (!is.null(names(args)) && nzchar(names(args)[[i]])) names(args)[[i]] else names(wrapper[[2L]])[[i]] + captures[formal] <- list(args[[i]]) + } + index$delegation[derived] <- list(list( + original = original_key, + captures = captures, prelude = returned$prelude, + receiver = formals[[1L]], variable = variable + )) + values[[name]] <- derived + } + } + members <<- c(members, values[!names(values) %in% names(members)]) + } + if (length(node) == 4L) inspect(node[[4L]]) + } else if (member_head(node, "{")) for (child in as.list(node)[-1L]) inspect(child) + invisible(NULL) + } + inspect(fn[[3L]]) + old <- index$members[[type]] + index$members[type] <- list(c(members, old[!names(old) %in% names(members)])) + } + # Constructor constraints and registry-derived namespaces propagate through + # a bounded fixed point; no constructor or active property is called. + for (pass in seq_len(4L)) { + for (key in names(index$constructors)) { + ctor <- index$constructors[[key]] + env <- index$package_roots + for (name in names(index$constructor_inputs[[key]])) env[name] <- list(index$constructor_inputs[[key]][[name]]) + env[ctor$target] <- list(member_value(type = ctor$type)) + for (field in names(ctor$fields)) { + if (!is.na(index$members[[ctor$type]][[field]])) next + recipe <- ctor$fields[[field]] + expr <- recipe$expr + if (isTRUE(recipe$active) && member_head(expr, "function")) expr <- expr[[3L]] + value <- member_infer(expr, index, env) + if (length(value$type) == 1L && value$type != ".never") index$properties[[ctor$type]][field] <- list(value) + } + member_walk(ctor$body, function(node) { + if (!member_head(node, "makeActiveBinding") || length(node) < 4L || + !identical(member_name(node[[4L]]), ctor$target)) { + return() + } + member_walk(node[[3L]], function(child) { + if (!is.call(child) || !member_head(child[[1L]], "[[")) { + return() + } + registry <- member_name(child[[1L]][[2L]]) + methods <- member_lookup(index$registries, registry) + if (is.null(methods) || length(child) != 2L || + !identical(member_name(child[[2L]]), ctor$target)) { + return() + } + index$namespace_owners[[registry]] <- unique(c(index$namespace_owners[[registry]], ctor$type)) + for (name in names(methods)) { + target <- member_lookup(index$constructors, methods[[name]]) + if (is.null(target)) next + formal <- names(index$definitions[[methods[[name]]]][[2L]])[[1L]] + index$constructor_inputs[[methods[[name]]]][formal] <- list(member_value(type = ctor$type)) + index$properties[[ctor$type]][name] <- list(member_value(type = target$type)) + index$members[[ctor$type]][name] <- NA_character_ + } + }) + }) + } + index$cache <- new.env(parent = emptyenv()) + } + for (name in names(input$snapshots)) { + for (field in names(input$snapshots[[name]]$fields)) { + record <- input$snapshots[[name]]$fields[[field]] + if (identical(record$kind, "active") && member_head(record$syntax, "function")) { + env <- c(lapply(record$captures, member_literal), index$package_roots) + index$properties[[name]][field] <- list(member_infer(record$syntax[[3L]], index, env)) + } + } + } + for (key in names(index$definitions)) { + fn <- index$definitions[[key]] + if (!member_head(fn, "function")) next + member_walk(fn[[3L]], function(node) { + if (!member_head(node, "assign") || length(node) < 4L) { + return() + } + args <- as.list(node)[-1L] + registry <- member_name(if (!is.null(args$envir)) args$envir else args[[3L]]) + name_arg <- member_name(args[[1L]]) + value_arg <- member_name(args[[2L]]) + if (is.null(registry) || !registry %in% names(index$namespace_owners) || + !all(c(name_arg, value_arg) %in% names(fn[[2L]]))) { + return() + } + index$registration_rules[key] <- list(list( + formals = names(fn[[2L]]), + name_arg = name_arg, value_arg = value_arg, owners = index$namespace_owners[[registry]] + )) + }, descend_functions = FALSE) + } + # Source-only active property declarations and literal registration loops. + # These recipes are analyzed against lexical metadata, never executed. + for (code in input$expressions) { + member_walk(code, function(node) { + if (!member_head(node, "lapply") || length(node) < 3L || + !member_head(node[[3L]], "function")) { + return() + } + values <- member_data(node[[2L]], constants) + if (!is.character(values) || length(values) > 256L) { + return() + } + variable <- names(node[[3L]][[2L]])[[1L]] + member_walk(node[[3L]][[3L]], function(child) { + if (!member_head(child, "makeActiveBinding") || length(child) < 4L || + !identical(member_name(child[[2L]]), variable)) { + return() + } + target <- member_name(child[[4L]]) + if (is.null(target) || !target %in% names(index$package_roots)) { + return() + } + getter <- child[[3L]] + if (!member_head(getter, "function")) { + return() + } + for (name in values) { + env <- index$package_roots + env[variable] <- list(member_literal(name)) + index$members[[target]][name] <- NA_character_ + index$properties[[target]][name] <- list(member_infer(getter[[3L]], index, env)) + } + }) + }) + for (node in code) { + if (!member_head(node, "makeActiveBinding") || length(node) < 4L || + !member_head(node[[3L]], "function")) { + next + } + name <- member_strings(node[[2L]]) + target <- member_name(node[[4L]]) + if (length(name) != 1L || is.null(target) || !target %in% names(index$package_roots)) next + index$members[[target]][name] <- NA_character_ + index$properties[[target]][name] <- list(member_infer(node[[3L]][[3L]], index, index$package_roots)) + } + } + index$record_dispatch_classes <- unique(unlist(lapply(index$classes, function(x) utils::tail(x, 1L)))) + for (name in names(index$definitions)) { + recipe <- member_s4_recipe(index$definitions[[name]], index, list()) + if (!is.null(recipe) && is.null(recipe$union)) { + index$package_roots[name] <- list(member_value(type = "function", + s4_generator = list(name = recipe$name, package = index$package))) + } + } + for (name in names(input$s4_roots)) index$package_roots[name] <- input$s4_roots[name] + for (name in names(index$definitions)) { + node <- index$definitions[[name]] + if (identical(member_s7_method(node, index, index$package_roots), "new_class")) { + value <- member_infer(node, index, index$package_roots) + if (!is.null(value$s7_generator)) index$package_roots[name] <- list(value) + } + } + for (name in names(input$s7_roots)) index$package_roots[name] <- input$s7_roots[name] + for (name in names(input$s4_objects)) { + class <- input$s4_objects[[name]] + index$package_roots[name] <- list(member_s4_shape(class$name, index, list(), class$package)) + } + index$roots <- index$package_roots[intersect(names(index$package_roots), index$exports)] + for (name in names(index$roots)) index$namespace_roots[paste(input$package, name, sep = "::")] <- list(index$roots[[name]]) + index$cache <- new.env(parent = emptyenv()) + index +} diff --git a/R/member-inference.R b/R/member-inference.R new file mode 100644 index 00000000..1cea92a6 --- /dev/null +++ b/R/member-inference.R @@ -0,0 +1,1182 @@ +# Static receiver analysis. All inputs are syntax or inert metadata. +# No document expression, method, getter, or default is evaluated. + +member_head <- function(x, name) { + !missing(x) && is.call(x) && is.symbol(x[[1L]]) && identical(as.character(x[[1L]]), name) +} + +member_name <- function(x) { + if (missing(x)) { + return(NULL) + } + if (is.symbol(x)) { + return(as.character(x)) + } + if (is.character(x) && length(x) == 1L) { + return(x) + } + NULL +} + +member_key <- function(x) { + if (is.symbol(x)) { + return(as.character(x)) + } + if (member_head(x, "$") && length(x) == 3L) { + lhs <- member_key(x[[2L]]) + rhs <- member_name(x[[3L]]) + if (!is.null(lhs) && !is.null(rhs)) { + return(paste(lhs, rhs, sep = "$")) + } + } + NULL +} + +member_walk <- function(x, visit, descend_functions = TRUE) { + if (missing(x)) { + return(invisible(NULL)) + } + visit(x) + if (is.call(x) || is.expression(x)) { + if (!descend_functions && member_head(x, "function")) { + return(invisible(NULL)) + } + for (child in as.list(x)) member_walk(child, visit, descend_functions) + } + invisible(NULL) +} + +member_strings <- function(x) { + if (is.character(x)) { + return(x) + } + if (member_head(x, "c")) { + args <- as.list(x)[-1L] + if (all(vapply(args, is.character, logical(1L)))) { + return(unlist(args)) + } + } + character() +} + +member_lookup <- function(x, key) { + if (is.null(x) || is.null(key) || length(key) != 1L || is.na(key) || !key %in% names(x)) { + return(NULL) + } + x[[key]] +} + +member_value <- function( + type = NULL, function_key = NULL, receiver = NULL, + fields = NULL, function_expr = NULL, closure = NULL, receiver_name = NULL, + receiver_value = NULL, literal = NULL, known_literal = FALSE, + elements = NULL, classes = NULL, reason = NULL, element_shape = NULL, + open = FALSE, result_shape = NULL, binding_expr = NULL, binding_env = NULL, + metadata = NULL, slots = NULL, slot_types = NULL, s4_class = NULL, + s4_generator = NULL, r6_private = NULL, r6_super = NULL, r6_self = NULL +) { + list( + type = type, function_key = function_key, receiver = receiver, + fields = fields, function_expr = function_expr, closure = closure, + receiver_name = receiver_name, receiver_value = receiver_value, + literal = literal, known_literal = known_literal, elements = elements, + classes = classes, reason = reason, element_shape = element_shape, + open = open, result_shape = result_shape, + binding_expr = binding_expr, binding_env = binding_env, metadata = metadata, + slots = slots, slot_types = slot_types, s4_class = s4_class, + s4_generator = s4_generator, r6_private = r6_private, + r6_super = r6_super, r6_self = r6_self + ) +} + +member_literal <- function(x) { + type <- if (is.null(x)) "NULL" else typeof(x) + member_value(type = type, literal = x, known_literal = TRUE) +} + +member_join <- function(a, b) { + if (identical(a$type, ".never")) { + return(b) + } + if (identical(b$type, ".never")) { + return(a) + } + if (identical(a, b)) { + return(a) + } + if (!length(a$type) || !length(b$type)) { + return(member_value(reason = "unknown_branch")) + } + fields <- NULL + if (!is.null(a$fields) && !is.null(b$fields)) { + common <- intersect(names(a$fields), names(b$fields)) + fields <- stats::setNames(lapply(common, function(n) member_join(a$fields[[n]], b$fields[[n]])), common) + } + slots <- NULL + slot_types <- NULL + if (!is.null(a$slot_types) && !is.null(b$slot_types)) { + common <- intersect(names(a$slot_types), names(b$slot_types)) + slot_types <- stats::setNames(lapply(common, function(n) { + member_s4_join_types(a$slot_types[[n]], b$slot_types[[n]], a$s4_class$package, b$s4_class$package) + }), common) + slots <- stats::setNames(lapply(common, function(n) { + member_join(member_lookup(a$slots, n), member_lookup(b$slots, n)) + }), common) + } + value <- member_value( + type = sort(unique(c(a$type, b$type))), fields = fields, + slots = slots, slot_types = slot_types, + s4_class = if (identical(a$s4_class, b$s4_class)) a$s4_class else NULL, + element_shape = if (!is.null(a$element_shape) && !is.null(b$element_shape)) member_join(a$element_shape, b$element_shape) else NULL, + classes = if (identical(a$classes, b$classes)) a$classes else NULL + ) + if (isTRUE(a$s7) && isTRUE(b$s7)) value$s7 <- TRUE + value +} + +member_classes <- function(value, index) { + if (length(value$type) != 1L) { + return(character()) + } + if (length(value$classes)) { + return(value$classes) + } + classes <- member_lookup(index$classes, value$type) + if (is.null(classes)) value$type else classes +} + +member_members <- function(value, index, bindings = list(), accessor = "$") { + if (!length(value$type) || any(value$type %in% c(".never", ".missing"))) { + return(character()) + } + if (identical(accessor, "@")) { + slots <- names(value$slot_types) + return(stats::setNames(rep(NA_character_, length(slots)), slots)) + } + if (length(value$classes) && !all(value$classes %in% c("data.frame", "list", "environment", "R6")) && + !any(value$classes %in% names(index$members))) { + return(character()) + } + sets <- lapply(value$type, function(type) { + out <- member_lookup(index$members, type) + if (is.null(out)) character() else out + }) + common <- Reduce(intersect, lapply(sets, names)) + out <- sets[[1L]][common] + dynamic <- member_lookup(bindings, ".__member_properties__") + if (length(value$type) == 1L) { + extra <- setdiff(names(member_lookup(dynamic, value$type)), names(out)) + out <- c(out, stats::setNames(rep(NA_character_, length(extra)), extra)) + } + if (!is.null(value$fields)) { + extra <- setdiff(names(value$fields), names(out)) + out <- c(out, stats::setNames(rep(NA_character_, length(extra)), extra)) + } + out +} + +# 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) { + if (is.null(value)) { + return(NULL) + } + if (depth > 4L) { + return("...") + } + list( + type = value$type, classes = value$classes, literal = if (isTRUE(value$known_literal) && + length(value$literal) <= 8L) { + value$literal + } else { + NULL + }, + known = value$known_literal, function_key = value$function_key, + fields = lapply(value$fields, member_shape_key, depth + 1L), + slots = lapply(value$slots, member_shape_key, depth + 1L), + slot_types = value$slot_types, s4_class = value$s4_class, + s4_generator = value$s4_generator, + s7 = value$s7, s7_descriptor = value$s7_descriptor, + r6_private = member_shape_key(value$r6_private, depth + 1L), + r6_super = member_shape_key(value$r6_super, depth + 1L), + r6_self = member_shape_key(value$r6_self, depth + 1L), + elements = lapply(value$elements, member_shape_key, depth + 1L), + element_shape = if (!is.null(value$element_shape)) member_shape_key(value$element_shape, depth + 1L) else NULL + ) +} + +member_cacheable <- function(value, depth = 0L) { + if (is.null(value)) { + return(TRUE) + } + if (depth > 4L || !is.null(value$function_expr) || !is.null(value$closure) || + !is.null(value$binding_expr)) { + return(FALSE) + } + if (value$known_literal && length(value$literal) > 8L) { + return(FALSE) + } + all(vapply( + c(value$fields, value$slots, value$elements, value[c("r6_private", "r6_super", "r6_self")], + if (!is.null(value$element_shape)) list(value$element_shape)), + member_cacheable, logical(1L), depth + 1L + )) +} + +member_assigned_names <- function(node) { + out <- character() + member_walk(node, function(x) { + if (member_head(x, "<-") || member_head(x, "=") || member_head(x, ":=")) { + target <- x[[2L]] + while (is.call(target) && length(target) > 1L) target <- target[[2L]] + name <- member_name(target) + if (!is.null(name)) out <<- c(out, name) + } + }, descend_functions = FALSE) + unique(out) +} + +member_infer <- function( + expr, index, bindings = list(), receiver = NULL, + depth = 0L, trail = character(), budget = NULL, context = NULL +) { + unknown <- member_value(reason = "unsupported") + if (missing(expr)) { + return(member_value(type = ".missing")) + } + if (is.null(budget)) { + budget <- new.env(parent = emptyenv()) + budget$remaining <- 20000L + budget$exhausted <- FALSE + budget$transient <- FALSE + } + 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. + if (!is.null(budget$time_limit) && is.null(budget$deadline)) { + budget$deadline <- proc.time()[[3L]] + budget$time_limit + } + if (depth > 64L || budget$remaining < 0L || + (!is.null(budget$deadline) && proc.time()[[3L]] > budget$deadline)) { + budget$exhausted <- TRUE + return(member_value(reason = "budget")) + } + infer <- function(x, env = bindings, ctx = context) { + member_infer(x, index, env, receiver, depth + 1L, trail, budget, ctx) + } + intrinsic <- function(name) { + at <- bindings$.__member_position__ + history <- member_lookup(index$document_bindings, name) + shadowed <- length(history) && (is.null(at) || any(vapply( + history, + function(item) member_before(item$end, at), logical(1L) + ))) + !name %in% names(bindings) && + !shadowed && + ((!name %in% names(index$definitions) && name %in% member_base_intrinsics) || + (name %in% index$intrinsics && (is.null(index$document_bindings) || !is.null(context$key)))) + } + package_env <- if (!is.null(index$package_roots)) index$package_roots else index$roots + join_env <- function(a, b) { + keys <- union(names(a), names(b)) + stats::setNames(lapply(keys, function(key) { + x <- member_lookup(a, key) + y <- member_lookup(b, key) + if (is.null(x) || is.null(y)) unknown else member_join(x, y) + }), keys) + } + # Flow records keep early returns separate from fall-through values. + flow <- function(node, env) { + env <- member_s4_effect(node, index, env) + if (member_head(node, "{")) { + state <- list( + value = member_literal(NULL), env = env, + returns = member_value(type = ".never"), falls = TRUE + ) + for (child in as.list(node)[-1L]) { + if (!state$falls) break + next_state <- flow(child, state$env) + state$returns <- member_join(state$returns, next_state$returns) + state$value <- next_state$value + state$env <- next_state$env + state$falls <- next_state$falls + } + return(state) + } + if (member_head(node, "return")) { + result <- if (length(node) > 1L) infer(node[[2L]], env) else member_literal(NULL) + return(list(value = result, env = env, returns = result, falls = FALSE)) + } + if (member_head(node, "if")) { + cond <- infer(node[[2L]], env) + yes <- !isTRUE(cond$known_literal) || !identical(cond$literal, FALSE) + no <- !isTRUE(cond$known_literal) || !identical(cond$literal, TRUE) + a <- if (yes) flow(node[[3L]], env) else NULL + b <- if (no) { + if (length(node) == 4L) { + flow(node[[4L]], env) + } else { + list( + value = member_literal(NULL), env = env, + returns = member_value(type = ".never"), falls = TRUE + ) + } + } else { + NULL + } + if (is.null(a)) { + return(b) + } + if (is.null(b)) { + return(a) + } + falls <- a$falls || b$falls + out_env <- if (!a$falls) b$env else if (!b$falls) a$env else join_env(a$env, b$env) + value <- if (!a$falls) b$value else if (!b$falls) a$value else member_join(a$value, b$value) + return(list( + value = value, env = out_env, + returns = member_join(a$returns, b$returns), falls = falls + )) + } + if (member_head(node, "for") || member_head(node, "while")) { + # Preserve bindings not assigned by the loop. Never assume one + # iteration represents all iterations of an unknown loop. + writes <- member_assigned_names(node) + if (member_head(node, "for")) writes <- c(writes, member_name(node[[2L]])) + for (name in writes) env[name] <- list(unknown) + has_return <- FALSE + member_walk(node, function(x) { + if (member_head(x, "return")) has_return <<- TRUE + }, descend_functions = FALSE) + return(list( + value = member_literal(NULL), env = env, + returns = if (has_return) unknown else member_value(type = ".never"), falls = TRUE + )) + } + if (member_head(node, ":=")) { + bound <- member_s7_bind(node, index, env) + if (!is.null(bound)) node <- bound + } + if (member_head(node, "<-") || member_head(node, "=")) { + lhs <- node[[2L]] + value <- infer(node[[3L]], env) + if (is.symbol(lhs)) { + env[as.character(lhs)] <- list(value) + } else if (member_head(lhs, "$") || member_head(lhs, "[[") || member_head(lhs, "@")) { + name <- member_name(lhs[[2L]]) + field <- member_name(lhs[[3L]]) + object <- member_lookup(env, name) + surface <- if (member_head(lhs, "@")) "slots" else "fields" + if (!is.null(object[[surface]]) && !is.null(field)) { + if (!is.null(value$function_expr)) { + value$closure[name] <- NULL + value$receiver_name <- name + } + object[[surface]][field] <- list(value) + env[name] <- list(object) + } else if (!is.null(name)) { + env[name] <- list(unknown) + } + } else if (member_head(lhs, "class")) { + name <- member_name(lhs[[2L]]) + object <- member_lookup(env, name) + classes <- member_strings(node[[3L]]) + if (!is.null(object) && length(classes)) { + object$type <- classes[[1L]] + object$classes <- classes + env[name] <- list(object) + } else if (!is.null(name)) env[name] <- list(unknown) + } + return(list(value = value, env = env, returns = member_value(type = ".never"), falls = TRUE)) + } + # Arbitrary reflection can mutate local bindings. Do not retain types + # through it. Reviewed package metadata wrappers have their own rules. + if (member_head(node, "assign") || member_head(node, "eval") || member_head(node, "source")) { + env <- lapply(env, function(x) unknown) + } + value <- infer(node, env) + list( + value = value, env = env, returns = member_value(type = ".never"), + falls = !identical(value$type, ".never") + ) + } + analyze <- function(body, env) { + state <- flow(body, env) + if (state$falls) member_join(state$returns, state$value) else state$returns + } + bind_arguments <- function(fn, actuals, env) { + formals <- as.list(fn[[2L]]) + keys <- names(formals) + dots <- match("...", keys) + before_dots <- if (is.na(dots)) keys else keys[seq_len(dots - 1L)] + supplied <- names(actuals) + if (is.null(supplied)) supplied <- rep("", length(actuals)) + matched <- rep(FALSE, length(actuals)) + used <- character() + for (i in which(nzchar(supplied))) { + name <- supplied[[i]] + candidates <- if (name %in% keys) name else before_dots[startsWith(before_dots, name)] + if (length(candidates) == 1L && candidates != "...") { + if (candidates %in% used) { + return(NULL) + } + env[candidates] <- list(actuals[[i]]) + used <- c(used, candidates) + matched[[i]] <- TRUE + } else if (length(candidates) > 1L) { + return(NULL) + } + } + available <- setdiff(before_dots, used) + for (i in which(!matched & !nzchar(supplied))) { + if (!length(available)) break + name <- available[[1L]] + available <- available[-1L] + env[name] <- list(actuals[[i]]) + used <- c(used, name) + matched[[i]] <- TRUE + } + if (any(!matched) && is.na(dots)) { + return(NULL) + } + if (!is.na(dots)) env["..."] <- list(member_value(type = "list", elements = actuals[!matched])) + for (name in setdiff(keys, c(used, "..."))) { + env[name] <- list(if (identical(formals[[name]], quote(expr = ))) { + member_value(type = ".missing") + } else { + infer(formals[[name]], env) + }) + } + env + } + apply_function <- function(key = NULL, self = NULL, actuals = list(), + fn = NULL, lexical = package_env, dispatch = NULL) { + if (!is.null(key)) { + aliases <- character() + while (is.symbol(member_lookup(index$definitions, key))) { + if (key %in% c(aliases, trail)) { + return(member_value(reason = "alias_cycle")) + } + aliases <- c(aliases, key) + key <- as.character(index$definitions[[key]]) + } + if (key %in% trail) { + budget$transient <- TRUE + return(member_value(reason = "recursion")) + } + definition <- member_lookup(index$definitions, key) + fn <- definition + } + shape <- member_lookup(index$constructor_types, key) + if (!is.null(shape)) { + return(member_value(type = shape)) + } + if (!member_head(fn, "function")) { + return(unknown) + } + # A native instance binding exposes the inner method's formals. The + # outer factory takes the pointer and is never called for inference. + body <- fn[[3L]] + if (!is.null(self) && !is.null(key) && key %in% index$native_factories) { + returned <- member_returned_function(fn) + if (is.null(returned)) { + return(unknown) + } + fn <- returned$fn + } + env <- bind_arguments(fn, actuals, lexical) + if (is.null(env)) { + return(member_value(reason = "argument_matching")) + } + if (!is.null(self)) { + bound <- member_lookup(index$method_receivers, paste(self$type, key, sep = "|")) + if (is.null(bound)) bound <- "self" + env[bound] <- list(self) + } + delegated <- member_lookup(index$delegation, key) + if (!is.null(delegated) && !is.null(self)) { + scope <- package_env + scope[delegated$receiver] <- list(self) + if (!is.null(delegated$variable)) scope[delegated$variable] <- list(member_value(function_key = delegated$original)) + for (name in names(delegated$captures)) scope[name] <- list(infer(delegated$captures[[name]], scope)) + for (node in delegated$prelude) { + if (member_head(node, "<-") && is.symbol(node[[2L]])) { + scope[as.character(node[[2L]])] <- list(infer(node[[3L]], scope)) + } + } + env <- utils::modifyList(scope, env) + for (name in setdiff(names(scope), names(fn[[2L]]))) env[name] <- list(scope[[name]]) + } + # Only package summaries are cached. Local closures can share syntax + # while capturing different values and must keep their lexical identity. + cache_values <- env[intersect(names(env), c(names(fn[[2L]]), "self"))] + cache_key <- if (!is.null(key) && all(vapply(cache_values, member_cacheable, logical(1L)))) { + digest::digest(list( + key, + member_shape_key(self), lapply(env[intersect(names(env), c(names(fn[[2L]]), "self"))], member_shape_key), + dispatch + ), algo = "xxhash64") + } else { + NULL + } + if (!is.null(cache_key) && exists(cache_key, index$cache, inherits = FALSE)) { + return(get(cache_key, index$cache, inherits = FALSE)) + } + ctor <- member_lookup(index$constructors, key) + summary_index <- index + if (!is.null(key) && !is.null(index$document_bindings)) { + summary_index <- list2env(as.list(index), parent = emptyenv()) + summary_index$document_bindings <- NULL + summary_index$attached_roots <- NULL + } + if (!is.null(ctor)) { + fields <- list() + for (name in names(ctor$fields)) { + 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) + } else if (isTRUE(recipe$active)) { + body <- recipe$expr + if (member_head(body, "function")) body <- body[[3L]] + value <- member_infer(body, summary_index, c(env, stats::setNames(list(member_value(type = ctor$type)), ctor$target)), + depth = depth + 1L, trail = c(trail, key), budget = budget + ) + } else { + value <- member_infer(recipe$expr, summary_index, env, + depth = depth + 1L, trail = c(trail, key), budget = budget + ) + } + fields[name] <- list(value) + } + result <- member_value(type = ctor$type, classes = ctor$classes, fields = fields) + } else { + body <- fn[[3L]] + ctx <- list(key = key, actuals = actuals, formals = names(fn[[2L]]), dispatch = dispatch) + result <- member_infer(body, summary_index, env, + depth = depth + 1L, + trail = if (is.null(key)) trail else c(trail, key), budget = budget, context = ctx + ) + } + if (!is.null(cache_key) && !budget$exhausted && !isTRUE(budget$transient) && is.null(result$function_expr)) { + size <- as.numeric(utils::object.size(result)) + if (size <= 1024^2) { + if (is.null(index$cache$.bytes)) index$cache$.bytes <- 0 + if (length(index$cache) >= 512L || index$cache$.bytes + size > 4 * 1024^2) { + rm(list = ls(index$cache, all.names = TRUE), envir = index$cache) + index$cache$.bytes <- 0 + } + assign(cache_key, result, index$cache) + index$cache$.bytes <- index$cache$.bytes + size + } + } + result + } + member <- function(lhs, name) { + dispatch_classes <- c( + names(index$members), names(index$classes), + unlist(lapply(index$namespace_indices, function(x) names(x$classes))) + ) + if (!is.null(lhs$fields) && any(lhs$classes %in% index$record_dispatch_classes)) { + dispatch_classes <- c(dispatch_classes, lhs$classes) + } + if (length(lhs$classes) && !all(lhs$classes %in% c("list", "environment", "data.frame", "R6")) && + !any(lhs$classes %in% dispatch_classes)) { + return(member_value(reason = "unresolved_dollar_dispatch")) + } + if (is.null(name)) { + return(unknown) + } + if (length(lhs$type) > 1L) { + return(Reduce(member_join, lapply(lhs$type, function(type) member(member_value(type = type), name)))) + } + dynamic <- member_lookup(member_lookup(member_lookup(bindings, ".__member_properties__"), lhs$type), name) + if (!is.null(dynamic)) { + return(dynamic) + } + value <- member_lookup(lhs$fields, name) + if (!is.null(value)) { + if (!is.null(value$receiver_name)) { + value$receiver_value <- if (is.null(lhs$r6_self)) lhs else lhs$r6_self + if (!is.null(value$receiver_value$r6_private)) { + value$closure$private <- value$receiver_value$r6_private + value$closure$private$r6_self <- value$receiver_value + } + if (!is.null(value$closure$super)) value$closure$super$r6_self <- value$receiver_value + } + if (!is.null(value$function_key)) value$receiver_value <- lhs + if (length(value$type) || !is.null(value$function_expr) || !is.null(value$function_key)) { + return(value) + } + } + 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) + } + raw <- member_lookup(member_lookup(index$raw_fields, lhs$type), name) + if (!is.null(raw)) { + return(member_value(type = raw)) + } + members <- member_lookup(index$members, lhs$type) + if (name %in% names(members) && !is.na(members[[name]])) { + return(member_value(function_key = members[[name]], receiver_value = lhs)) + } + unknown + } + if (is.symbol(expr)) { + key <- as.character(expr) + if (key %in% names(bindings)) { + value <- bindings[[key]] + if (!is.null(value$binding_expr)) { + return(infer(value$binding_expr, value$binding_env)) + } + return(value) + } + if (key %in% names(index$document_bindings) || key %in% names(index$attached_roots)) { + value <- member_resolve_document(key, index, bindings, budget, depth, trail) + if (!is.null(value)) { + return(value) + } + } + if (identical(key, "self") && !is.null(receiver)) { + return(member_value(type = receiver)) + } + if (key %in% names(index$definitions) && (is.null(index$document_bindings) || + !is.null(context$key))) { + return(member_value(function_key = key)) + } + # Imported roots must be supplied by the document/package lexical + # context. Never resurrect an unattached or shadowed root by name. + if (key %in% c("NA", "NA_real_", "NA_integer_", "NA_character_", "TRUE", "FALSE", "NULL")) { + return(switch(key, + `TRUE` = member_literal(TRUE), + `FALSE` = member_literal(FALSE), + `NULL` = member_literal(NULL), + unknown + )) + } + return(unknown) + } + if (!is.call(expr)) { + return(member_literal(expr)) + } + head <- member_name(expr[[1L]]) + if (is.null(head)) head <- "" + if (member_head(expr, "(")) { + return(infer(expr[[2L]])) + } + if (head %in% c("{", "if", "return")) { + return(analyze(expr, bindings)) + } + if (head == "switch" && intrinsic(head)) { + selector <- infer(expr[[2L]]) + alternatives <- as.list(expr)[-c(1L, 2L)] + keys <- names(alternatives) + position <- NULL + if (selector$known_literal && length(selector$literal) == 1L) { + if (is.character(selector$literal)) { + position <- match(selector$literal, keys) + } else if (is.numeric(selector$literal)) position <- as.integer(selector$literal) + if (length(position) == 1L && !is.na(position) && position >= 1L && position <= length(alternatives)) { + while (position < length(alternatives) && identical(alternatives[[position]], quote(expr = ))) position <- position + 1L + return(infer(alternatives[[position]])) + } + # An unnamed arm is the default for a character selector. + defaults <- if (is.null(keys)) integer() else which(!nzchar(keys)) + return(if (length(defaults) == 1L) infer(alternatives[[defaults]]) else member_literal(NULL)) + } + results <- lapply(seq_along(alternatives), function(i) { + if (identical(alternatives[[i]], quote(expr = ))) member_value(type = ".never") else infer(alternatives[[i]]) + }) + return(if (length(results)) Reduce(member_join, results) else member_literal(NULL)) + } + if (member_head(expr, "function")) { + return(member_value(function_expr = expr, closure = bindings)) + } + if (member_is_r6_call(expr, index, bindings)) { + return(member_r6_shape(expr, index, bindings, budget)) + } + s4 <- member_s4_call(expr, index, bindings, budget) + if (!is.null(s4)) return(s4) + if (head %in% member_s7_intrinsics || (member_head(expr[[1L]], "::") && + identical(member_name(expr[[1L]][[2L]]), "S7"))) { + s7 <- member_s7_call(expr, index, bindings, budget) + if (!is.null(s7)) return(s7) + } + if (member_head(expr, "::")) { + package <- member_name(expr[[2L]]) + name <- member_name(expr[[3L]]) + root <- member_lookup(index$namespace_roots, paste(package, name, sep = "::")) + if (!is.null(root)) { + return(root) + } + package_index <- member_lookup(index$namespace_indices, package) + if (!is.null(package_index) && name %in% package_index$exports && + name %in% names(package_index$definitions)) { + return(member_value( + function_key = name, metadata = package + )) + } + if (identical(package, index$package) && name %in% names(index$definitions) && + (is.null(index$exports) || name %in% index$exports)) { + return(member_value(function_key = name)) + } + return(unknown) + } + if (member_head(expr, "$")) { + lhs <- infer(expr[[2L]]) + out <- member(lhs, member_name(expr[[3L]])) + key <- member_key(expr) + if (!length(out$type) && is.null(out$function_key) && !is.null(key) && + key %in% names(index$definitions) && !member_name(expr[[2L]]) %in% names(bindings)) { + return(member_value(function_key = key)) + } + return(out) + } + if (member_head(expr, "@")) { + return(member_slot(infer(expr[[2L]]), member_name(expr[[3L]]), index, bindings, budget)) + } + if (head %in% c("[[", "[")) { + lhs <- infer(expr[[2L]]) + selector <- if (length(expr) >= 3L && !identical(expr[[3L]], quote(expr = ))) infer(expr[[3L]]) else unknown + if (isTRUE(selector$known_literal) && length(selector$literal) == 1L) { + name <- selector$literal + if (is.character(name)) { + return(member(lhs, name)) + } + if (head == "[[" && !is.null(lhs$elements) && is.numeric(name) && + name >= 1L && name <= length(lhs$elements)) { + return(lhs$elements[[name]]) + } + } + if (head == "[" && length(lhs$type) == 1L && lhs$type %in% c("double", "integer", "character", "logical", "list", "data.frame")) { + return(lhs) + } + if (!is.null(lhs$elements) && length(lhs$elements) && head == "[[") { + return(Reduce(member_join, lhs$elements)) + } + if (!is.null(lhs$element_shape) && head == "[[") { + return(lhs$element_shape) + } + # Registered [ methods are analyzed with their receiver argument. + classes <- member_classes(lhs, index) + keys <- paste0(head, ".", classes) + key <- keys[keys %in% names(index$definitions)] + if (length(key)) { + return(apply_function(key[[1L]], actuals = list(lhs, selector))) + } + return(unknown) + } + if (head %in% c("UseMethod", "NextMethod") && intrinsic(head) && !is.null(context)) { + if (head == "UseMethod") { + generic <- member_strings(expr[[2L]]) + input <- if (length(expr) > 2L) { + infer(expr[[3L]]) + } else { + member_lookup(bindings, context$formals[[1L]]) + } + if (length(input$type) > 1L && length(generic) == 1L) { + return(Reduce(member_join, lapply(input$type, function(type) { + classes <- member_classes(member_value(type = type), index) + keys <- c(paste(generic, classes, sep = "."), paste0(generic, ".default")) + keys <- keys[keys %in% names(index$definitions)] + if (!length(keys)) { + return(unknown) + } + actuals <- context$actuals + actuals[[1L]] <- member_value(type = type) + apply_function(keys[[1L]], actuals = actuals, dispatch = keys[-1L]) + }))) + } + classes <- member_classes(input, index) + if (!length(classes) || !length(generic)) { + return(member_value(reason = "open_dispatch")) + } + keys <- c(paste(generic, classes, sep = "."), paste0(generic, ".default")) + keys <- keys[keys %in% names(index$definitions)] + } else { + keys <- context$dispatch + if (!length(keys)) { + return(unknown) + } + } + if (!length(keys)) { + return(unknown) + } + return(apply_function(keys[[1L]], actuals = context$actuals, dispatch = keys[-1L])) + } + if (head %in% index$nonreturning_functions && intrinsic(head)) { + return(member_value(type = ".never")) + } + args <- as.list(expr)[-1L] + if (head == "missing" && intrinsic(head) && length(args) == 1L && + identical(args[[1L]], as.name("..."))) { + dots <- member_lookup(bindings, "...") + if (!is.null(dots$elements)) { + return(member_literal(length(dots$elements) == 0L)) + } + } + actuals <- lapply(args, function(arg) { + if (identical(arg, quote(expr = ))) member_value(type = ".missing") else infer(arg) + }) + # Expand syntactic dots from a known argument list without evaluating it. + expanded <- list() + for (i in seq_along(args)) { + if (identical(args[[i]], as.name("...")) && !is.null(actuals[[i]]$elements)) { + expanded <- c(expanded, actuals[[i]]$elements) + } else { + expanded <- c(expanded, actuals[i]) + } + } + actuals <- expanded + 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)) + if (any(vapply(actuals, function(value) !is.null(value$s7_descriptor), logical(1L))) && + !any(vapply(classes, is.null, logical(1L)))) { + return(member_s7_value(type = "S7_union", s7_descriptor = list(kind = "union", classes = classes))) + } + } + arg <- function(i) if (length(actuals) >= i) actuals[[i]] else unknown + if (!is.null(head) && intrinsic(head)) { + if (head %in% c("list", "list2")) { + if (length(actuals) > 256L) { + return(member_value(type = "list", open = TRUE)) + } + nms <- names(actuals) + fields <- if (is.null(nms)) list() else actuals[nzchar(nms)] + return(member_value(type = "list", fields = fields, elements = actuals)) + } + if (head == "new.env") { + return(member_value(type = "environment", fields = list())) + } + if (head %in% c("invisible", "identity", "arg_match0", "arg_match", "set_props", "try_fetch", "local", "withAutoprint")) { + return(arg(1L)) + } + if (head %in% c("head", "tail") && length(arg(1L)$type) == 1L && + arg(1L)$type %in% c("data.frame", "integer", "double", "character", "logical", "list")) { + return(arg(1L)) + } + if (head == "tryCatch") { + result <- arg(1L) + for (name in intersect(names(actuals), c("error", "warning", "interrupt"))) { + handler <- actuals[[name]] + branch <- if (!is.null(handler$function_expr)) { + apply_function( + fn = handler$function_expr, + actuals = list(unknown), lexical = handler$closure + ) + } else { + unknown + } + result <- member_join(result, branch) + } + return(result) + } + if (head %in% c("&&", "||") && isTRUE(arg(1L)$known_literal)) { + if (head == "&&" && identical(arg(1L)$literal, FALSE)) { + return(member_literal(FALSE)) + } + if (head == "||" && identical(arg(1L)$literal, TRUE)) { + return(member_literal(TRUE)) + } + } + if (head == "structure") { + out <- arg(1L) + classes <- actuals[["class"]] + if (!is.null(classes) && classes$known_literal) { + out$type <- classes$literal[[1L]] + out$classes <- classes$literal + } + return(out) + } + if (head == "data.frame") { + return(member_value(type = "data.frame", classes = "data.frame", fields = actuals[nzchar(names(actuals))])) + } + if (head == "length") { + x <- arg(1L) + if (!is.null(x$elements)) { + return(member_literal(length(x$elements))) + } + if (x$known_literal) { + return(member_literal(length(x$literal))) + } + return(member_value(type = "integer")) + } + if (head == "startsWith" && arg(1L)$known_literal && arg(2L)$known_literal) { + return(member_literal(startsWith(arg(1L)$literal, arg(2L)$literal))) + } + if (head %in% c("c", ":", "seq", "seq_len", "seq_along", "rep", "rep.int")) { + types <- unique(unlist(lapply(actuals, function(x) x$type))) + if (any(!vapply(actuals, function(x) length(x$type) > 0L, logical(1L)))) { + return(unknown) + } + type <- if ("character" %in% types) "character" else if (head %in% c(":", "seq_len", "seq_along")) "integer" else if ("double" %in% types) "double" else if ("integer" %in% types) "integer" else if ("logical" %in% types) "logical" else "list" + if (head == "c" && all(vapply(actuals, function(x) isTRUE(x$known_literal), logical(1L)))) { + # Concatenate literal data only, never eval the original call. + return(member_literal(unlist(lapply(actuals, function(x) x$literal), recursive = FALSE))) + } + return(member_value(type = type)) + } + simple_types <- c( + as.character = "character", character = "character", as.integer = "integer", + integer = "integer", as.numeric = "double", as.double = "double", numeric = "double", + double = "double", as.logical = "logical", logical = "logical", as.raw = "raw", raw = "raw", + charToRaw = "raw", as.Date = "Date", as.POSIXct = "POSIXct", factor = "factor", + paste = "character", paste0 = "character", sprintf = "character", names = "character" + ) + if (head %in% names(simple_types)) { + return(member_value(type = unname(simple_types[[head]]))) + } + if (head %in% c("is.null", "missing", "isTRUE", "isFALSE", "inherits", "is.character", "is.numeric", "is.integer", "is.logical", "is.list", "is_character", "is_list", "is_bool")) { + x <- arg(1L) + if (!length(x$type)) { + return(member_value(type = "logical")) + } + if (length(x$type) != 1L) { + return(member_value(type = "logical")) + } + yes <- switch(head, + is.null = identical(x$type, "NULL"), + missing = identical(x$type, ".missing") || + (identical(member_name(args[[1L]]), "...") && identical(x$type, "list") && + !is.null(x$elements) && length(x$elements) == 0L), + isTRUE = if (x$known_literal) identical(x$literal, TRUE) else NA, + isFALSE = if (x$known_literal) identical(x$literal, FALSE) else NA, + inherits = if (isTRUE(arg(2L)$known_literal)) arg(2L)$literal %in% member_classes(x, index) else NA, + is.character = identical(x$type, "character"), + is.numeric = x$type %in% c("double", "integer"), + is.integer = identical(x$type, "integer"), + is.logical = identical(x$type, "logical"), + is.list = identical(x$type, "list"), + is_character = identical(x$type, "character"), + is_list = identical(x$type, "list"), + is_bool = if (x$known_literal) is.logical(x$literal) && length(x$literal) == 1L && !is.na(x$literal) else NA + ) + return(if (length(yes) == 1L && !is.na(yes)) member_literal(yes) else member_value(type = "logical")) + } + if (head == "lapply") { + xs <- arg(1L)$elements + fn <- arg(2L) + if (is.null(xs)) { + input <- if (is.null(arg(1L)$element_shape)) unknown else arg(1L)$element_shape + value <- if (!is.null(fn$function_expr)) { + apply_function(actuals = list(input), fn = fn$function_expr, lexical = fn$closure) + } else { + apply_function(fn$function_key, actuals = list(input)) + } + return(member_value(type = "list", element_shape = value)) + } + if (length(xs) > 32L) { + return(member_value(type = "list")) + } + elements <- lapply(xs, function(x) { + if (!is.null(fn$function_expr)) { + apply_function(actuals = list(x), fn = fn$function_expr, lexical = fn$closure) + } else { + apply_function(fn$function_key, actuals = list(x)) + } + }) + return(member_value(type = "list", elements = elements)) + } + if (head == "Reduce") { + fn <- arg(1L) + xs <- arg(2L)$elements + init <- member_lookup(actuals, "init") + if (is.null(init) && length(actuals) >= 3L) init <- arg(3L) + if (is.null(xs)) { + if (is.null(init)) { + return(unknown) + } + input <- if (is.null(arg(2L)$element_shape)) unknown else arg(2L)$element_shape + next_shape <- if (!is.null(fn$function_expr)) { + apply_function( + fn = fn$function_expr, + actuals = list(init, input), lexical = fn$closure + ) + } else { + unknown + } + # Prove a shape-preserving transfer for any number of inputs. + if (identical(member_shape_key(init), member_shape_key(next_shape))) { + return(init) + } + return(unknown) + } + if (length(xs) > 32L) { + return(unknown) + } + if (is.null(init)) { + if (!length(xs)) { + return(member_literal(NULL)) + } + init <- xs[[1L]] + xs <- xs[-1L] + } + for (input in xs) { + init <- if (!is.null(fn$function_expr)) { + apply_function( + fn = fn$function_expr, + actuals = list(init, input), lexical = fn$closure + ) + } else { + apply_function(fn$function_key, actuals = list(init, input)) + } + } + return(init) + } + } + operators <- c("+", "-", "*", "/", "^", "%%", "%/%", "&", "|", "!", "==", "!=", ">", "<", ">=", "<=", "&&", "||") + if (head %in% operators && intrinsic(head)) { + keys <- lapply(actuals[seq_len(min(2L, length(actuals)))], function(value) { + candidates <- paste(head, member_classes(value, index), sep = ".") + candidates <- candidates[candidates %in% names(index$definitions)] + if (length(candidates)) candidates[[1L]] else character() + }) + keys <- unique(unlist(keys)) + if (length(keys) == 1L) { + return(apply_function(keys[[1L]], actuals = actuals)) + } + if (length(keys) > 1L) { + return(member_value(reason = "conflicting_dispatch")) + } + if (head %in% c("==", "!=", ">", "<", ">=", "<=") && length(actuals) == 2L && + all(vapply(actuals, function(x) x$known_literal && length(x$literal) == 1L && is.atomic(x$literal), logical(1L)))) { + x <- arg(1L)$literal + y <- arg(2L)$literal + return(member_literal(switch(head, + `==` = x == y, + `!=` = x != y, + `>` = x > y, + `<` = x < y, + `>=` = x >= y, + `<=` = x <= y + ))) + } + if (head %in% c("!", "&&", "||") && all(vapply(actuals, function(x) x$known_literal && is.logical(x$literal) && length(x$literal) == 1L, logical(1L)))) { + x <- arg(1L)$literal + y <- arg(2L)$literal + return(member_literal(switch(head, + `!` = !x, + `&&` = x && y, + `||` = x || y + ))) + } + if (all(vapply(actuals, function(x) length(x$type) == 1L && x$type %in% c("integer", "double", "logical", "character"), logical(1L)))) { + return(member_value(type = if (head %in% c("+", "-", "*", "/", "^", "%%", "%/%")) "double" else "logical")) + } + return(unknown) + } + callee <- infer(expr[[1L]]) + if (identical(callee$metadata, "S7") && callee$function_key %in% member_s7_intrinsics) { + return(member_s7_call(expr, index, bindings, budget, callee$function_key)) + } + if (!is.null(callee$s7_generator)) { + return(member_s7_construct(callee, actuals, index, bindings, budget)) + } + if (!is.null(callee$s4_generator)) { + return(member_s4_construct(callee$s4_generator, actuals, index, bindings, budget)) + } + if (!is.null(callee$result_shape)) { + return(callee$result_shape) + } + if (!is.null(callee$metadata)) { + package_index <- member_lookup(index$namespace_indices, callee$metadata) + if (is.null(package_index)) { + return(unknown) + } + env <- package_index$package_roots + env$.__member_callee__ <- member_value(function_key = callee$function_key) + call <- as.call(c( + list(as.name(".__member_callee__")), + stats::setNames(lapply(seq_along(actuals), function(i) as.name(paste0(".__member_arg", i))), names(actuals)) + )) + for (i in seq_along(actuals)) env[paste0(".__member_arg", i)] <- list(actuals[[i]]) + return(member_infer(call, package_index, env, depth = depth + 1L, budget = budget)) + } + if (!is.null(callee$function_expr)) { + env <- callee$closure + if (!is.null(callee$receiver_name)) env[callee$receiver_name] <- list(callee$receiver_value) + return(apply_function(actuals = actuals, fn = callee$function_expr, lexical = env)) + } + key <- callee$function_key + # Follow named aliases with the original abstract arguments intact. + aliases <- character() + while (!is.null(key) && is.symbol(member_lookup(index$definitions, key))) { + if (key %in% aliases) { + return(member_value(reason = "alias_cycle")) + } + aliases <- c(aliases, key) + key <- as.character(index$definitions[[key]]) + } + apply_function(key, callee$receiver_value, actuals) +} + +# Apply only statically described registration effects to a document context. +# The registration call itself is never evaluated. Unknown name/factory stops. +member_registration_effect <- function(expr, index, bindings) { + if (!is.call(expr)) { + return(bindings) + } + callee <- member_infer(expr[[1L]], index, bindings) + rule <- member_lookup(index$registration_rules, callee$function_key) + if (is.null(rule)) { + return(bindings) + } + args <- as.list(expr)[-1L] + nms <- names(args) + if (is.null(nms)) nms <- rep("", length(args)) + values <- list() + positional <- 1L + for (i in seq_along(args)) { + name <- nms[[i]] + if (!nzchar(name)) { + if (positional > length(rule$formals)) { + return(bindings) + } + name <- rule$formals[[positional]] + positional <- positional + 1L + } + values[name] <- list(member_infer(args[[i]], index, bindings)) + } + name <- values[[rule$name_arg]] + factory <- values[[rule$value_arg]] + if (!isTRUE(name$known_literal) || !is.character(name$literal) || length(name$literal) != 1L || is.null(factory)) { + return(bindings) + } + for (type in rule$owners) { + env <- bindings + env$.__factory__ <- factory + env$.__input__ <- member_value(type = type) + value <- member_infer(quote(.__factory__(.__input__)), index, env) + if (length(value$type)) bindings$.__member_properties__[[type]][name$literal] <- list(value) + } + bindings +} + +member_generic_index <- function(code) { + index <- new.env(parent = emptyenv()) + index$definitions <- list() + for (expr in parse(text = code, keep.source = FALSE)) { + if (member_head(expr, "<-") && is.symbol(expr[[2L]])) { + index$definitions[as.character(expr[[2L]])] <- list(expr[[3L]]) + } + } + index$generic <- TRUE + index$package <- NULL + index$cache <- new.env(parent = emptyenv()) + index$roots <- list() + index$namespace_roots <- list() + index$members <- list() + index$properties <- list() + index$raw_fields <- list() + index$nonreturning_functions <- "stop" + index$classes <- list() + index$intrinsics <- character() + index$constructors <- list() + index$constructor_types <- list() + index$native_factories <- character() + index$registration_rules <- list() + index$s4_classes <- list() + index$methods_attached <- TRUE + index +} diff --git a/R/member-metadata.R b/R/member-metadata.R new file mode 100644 index 00000000..c74722e7 --- /dev/null +++ b/R/member-metadata.R @@ -0,0 +1,412 @@ +# Metadata preparation runs in package workers. Request handlers only read +# serializable snapshots; no runtime object is retained as a completion hook. + +member_base_intrinsics <- c( + "list", "new.env", "invisible", "identity", "local", "withAutoprint", + "head", "tail", "tryCatch", "structure", "data.frame", "length", "startsWith", + "c", ":", "seq", "seq_len", "seq_along", "rep", "rep.int", "as.character", + "character", "as.integer", "integer", "as.numeric", "as.double", "numeric", + "double", "as.logical", "logical", "as.raw", "raw", "charToRaw", "as.Date", + "as.POSIXct", "factor", "paste", "paste0", "sprintf", "names", "is.null", + "missing", "isTRUE", "isFALSE", "inherits", "is.character", "is.numeric", + "is.integer", "is.logical", "is.list", "lapply", "Reduce", "UseMethod", + "NextMethod", "stop", "switch", "+", "-", "*", "/", "^", "%%", "%/%", "&", + "|", "!", "==", "!=", ">", "<", ">=", "<=", "&&", "||" +) + +member_binding <- function(env, name, materialize = FALSE) { + .Call("member_binding_c", env, name, materialize, PACKAGE = "languageserver") +} + +member_function_syntax <- function(fn) { + as.call(list(as.name("function"), formals(fn), body(fn))) +} + +member_snapshot <- function(env, max_depth = 4L, max_bindings = 5000L, s7_modes = list()) { + seen <- list() + remaining <- max_bindings + captures <- function(fn) { + scope <- environment(fn) + if (is.null(scope) || isNamespace(scope) || identical(scope, globalenv()) || + identical(scope, baseenv())) { + return(list()) + } + nms <- ls(scope, all.names = TRUE) + if (length(nms) > 100L) { + return(list()) + } + values <- list() + for (name in nms) { + record <- member_binding(scope, name) + x <- record[[2L]] + if (identical(record[[1L]], "value") && !is.object(x) && + is.atomic(x) && length(x) <= 100L) { + values[name] <- list(x) + } + } + values + } + visit <- function(current, depth) { + old <- which(vapply(seen, identical, logical(1L), current)) + if (length(old)) { + return(list(kind = "reference", id = old[[1L]])) + } + id <- length(seen) + 1L + seen[[id]] <<- current + if (depth > max_depth) { + return(list(kind = "environment", id = id, complete = FALSE)) + } + nms <- ls(current, all.names = TRUE) + if (length(nms) > remaining) { + return(list(kind = "environment", id = id, complete = FALSE)) + } + remaining <<- remaining - length(nms) + fields <- stats::setNames(lapply(nms, function(name) { + record <- member_binding(current, name) + value <- record[[2L]] + if (identical(record[[1L]], "active")) { + list( + kind = "active", syntax = if (typeof(value) == "closure") member_function_syntax(value), + captures = if (typeof(value) == "closure") captures(value) else list() + ) + } else if (identical(record[[1L]], "value")) { + describe(value, depth + 1L) + } else { + list(kind = "unknown", reason = "promise_not_forced") + } + }), nms) + list( + kind = "environment", id = id, complete = TRUE, + classes = attr(current, "class", exact = TRUE), fields = fields + ) + } + describe <- function(value, depth) { + descriptor <- member_s7_instance_descriptor(value, s7_modes) + if (!is.null(descriptor)) { + if (depth > max_depth) return(list(kind = "unknown", reason = "snapshot_depth")) + slots <- list() + for (name in names(descriptor$properties)) { + property <- descriptor$properties[[name]] + if (property$getter || property$setter) next + # Reserved base attributes use underscore storage in S7 1.0. + storage <- if (!is.null(attr(value, "_S7_class", exact = TRUE)) && name %in% c( + "names", "dim", "dimnames", "class", "tsp", "comment", "row.names" + )) paste0("_", name) else name + stored <- attr(value, storage, exact = TRUE) + if (!is.null(stored)) slots[name] <- list(describe(stored, depth + 1L)) + } + return(list(kind = "s7_instance", descriptor = descriptor, slots = slots)) + } + descriptor <- member_s7_runtime_descriptor(value, modes = s7_modes) + if (!is.null(descriptor)) return(list(kind = "s7", descriptor = descriptor)) + if (typeof(value) == "closure") { + list(kind = "function", syntax = member_function_syntax(value), captures = captures(value)) + } else if (is.environment(value)) { + visit(value, depth) + } else if (!is.object(value) && is.atomic(value) && length(value) <= 100L) { + list(kind = "literal", value = value) + } else if (typeof(value) == "list" && !is.object(value) && + depth <= max_depth && length(value) <= remaining) { + remaining <<- remaining - length(value) + list(kind = "list", elements = lapply(value, describe, depth + 1L)) + } else { + list(kind = "unknown", reason = "unsupported_storage") + } + } + visit(env, 0L) +} + +member_snapshot_shape <- function(snapshot) { + records <- list() + collect <- function(record) { + if (identical(record$kind, "environment")) { + records[[as.character(record$id)]] <<- record + for (field in record$fields) collect(field) + } else if (identical(record$kind, "list")) { + for (field in record$elements) collect(field) + } else if (identical(record$kind, "s7_instance")) { + for (field in record$slots) collect(field) + } + } + collect(snapshot) + decode <- function(record, trail = integer()) { + if (identical(record$kind, "reference")) { + if (record$id %in% trail) { + return(member_value(reason = "cycle")) + } + return(decode(records[[as.character(record$id)]], trail)) + } + if (identical(record$kind, "function")) { + return(member_value( + type = "function", function_expr = record$syntax, closure = lapply(record$captures, member_literal) + )) + } + if (identical(record$kind, "literal")) { + return(member_literal(record$value)) + } + if (identical(record$kind, "environment")) { + if (record$id %in% trail || !isTRUE(record$complete)) { + return(member_value(reason = "cycle_or_budget")) + } + return(member_value( + type = "environment", classes = record$classes, + fields = lapply(record$fields, decode, c(trail, record$id)) + )) + } + if (identical(record$kind, "s7_instance")) { + value <- member_s7_shape(record$descriptor) + for (name in names(record$slots)) value$slots[name] <- list(decode(record$slots[[name]], trail)) + return(value) + } + if (identical(record$kind, "s7")) { + return(if (identical(record$descriptor$kind, "class")) member_s7_generator(record$descriptor) else + member_s7_value(type = "S7_descriptor", s7_descriptor = record$descriptor)) + } + if (identical(record$kind, "list")) { + values <- lapply(record$elements, decode, trail) + fields <- if (is.null(names(values))) list() else values[nzchar(names(values))] + return(member_value(type = "list", fields = fields, elements = values)) + } + member_value(reason = if (identical(record$kind, "active")) "getter_not_invoked" else record$reason) + } + decode(snapshot) +} + +member_source_input <- function(root) { + definitions <- locations <- expressions <- list() + for (path in sort(list.files(file.path(root, "R"), "\\.[Rr]$", full.names = TRUE))) { + code <- parse(path, keep.source = FALSE) + expressions[[length(expressions) + 1L]] <- code + for (expr in code) { + if (!member_head(expr, "<-") || length(expr) != 3L) next + key <- member_key(expr[[2L]]) + if (is.null(key)) next + definitions[key] <- list(expr[[3L]]) + locations[key] <- list(basename(path)) + } + } + exports <- intrinsics <- character() + providers <- list(rlang = c( + "list2", "arg_match0", "arg_match", "try_fetch", + "is_character", "is_list", "is_bool", "abort" + ), S7 = member_s7_intrinsics, methods = member_methods_intrinsics) + for (expr in parse(file.path(root, "NAMESPACE"))) { + if (member_head(expr, "import") || member_head(expr, "importFrom")) { + provider <- member_name(expr[[2L]]) + allowed <- member_lookup(providers, provider) + if (member_head(expr, "importFrom")) { + allowed <- intersect( + allowed, + vapply(as.list(expr)[-c(1L, 2L)], member_name, character(1L)) + ) + } + intrinsics <- union(intrinsics, setdiff(allowed, names(definitions))) + } + if (member_head(expr, "export")) { + exports <- c( + exports, + vapply(as.list(expr)[-1L], member_name, character(1L)) + ) + } + } + list( + definitions = definitions, locations = locations, expressions = expressions, + exports = exports, intrinsics = intrinsics, package = read.dcf(file.path(root, "DESCRIPTION"))[[1L, "Package"]] + ) +} + +member_namespace_input <- function( + ns, package = unname(getNamespaceName(ns)), + exports = getNamespaceExports(ns) +) { + nms <- ls(ns, all.names = TRUE) + if (length(nms) > 10000L) stop("Namespace exceeds metadata budget") + definitions <- snapshots <- registries <- links <- descriptors <- s4_classes <- s4_roots <- s4_objects <- list() + s7_roots <- list() + s7_modes <- member_s7_capabilities() + functions <- values <- list() + for (name in nms) { + record <- member_binding(ns, name, materialize = TRUE) + value <- record[[2L]] + if (!identical(record[[1L]], "value")) next + descriptor <- member_s7_runtime_descriptor(value, modes = s7_modes) + if (!is.null(descriptor)) { + s7_roots[name] <- list(if (identical(descriptor$kind, "class")) { + member_s7_generator(descriptor) + } else { + member_s7_value(type = "S7_descriptor", s7_descriptor = descriptor) + }) + } else if ("S7_object" %in% attr(value, "class", exact = TRUE)) { + descriptor <- member_s7_instance_descriptor(value, s7_modes) + if (!is.null(descriptor)) { + holder <- new.env(parent = emptyenv()) + holder$object <- value + s7_roots[name] <- list(member_snapshot_shape(member_snapshot(holder, s7_modes = s7_modes))$fields$object) + } + } + if (isS4(value) && any(c("classRepresentation", "ClassUnionRepresentation") %in% + attr(value, "class", exact = TRUE))) { + descriptor <- member_s4_runtime_descriptor(value) + if (!is.null(descriptor)) s4_classes[descriptor$name] <- list(descriptor) + next + } + if (isS4(value) && typeof(value) != "closure" && is.null(s7_roots[[name]])) { + classes <- attr(value, "class", exact = TRUE) + if (is.character(classes) && length(classes) == 1L) { + owner <- attr(classes, "package", exact = TRUE) + s4_objects[name] <- list(list(name = as.character(classes), package = if (is.null(owner)) package else owner)) + } + } + if (typeof(value) == "closure") { + if ("classGeneratorFunction" %in% attr(value, "class", exact = TRUE)) { + class <- attr(value, "className", exact = TRUE) + if (is.character(class) && length(class) == 1L) { + owner <- attr(class, "package", exact = TRUE) + s4_roots[name] <- list(member_value(type = "function", s4_generator = list( + name = as.character(class), package = if (is.null(owner)) package else owner + ))) + } + } + if ("S7_class" %in% attr(value, "class", exact = TRUE)) { + type <- attr(value, "name", exact = TRUE) + properties <- attr(value, "properties", exact = TRUE) + if (is.character(type) && length(type) == 1L && is.list(properties)) { + descriptors[name] <- list(list(type = type, fields = names(properties))) + } + } + definitions[name] <- list(member_function_syntax(value)) + functions[name] <- list(value) + } else if (is.environment(value)) { + values[name] <- list(value) + } else if (!is.object(value) && is.atomic(value) && length(value) <= 256L) { + definitions[name] <- list(value) + } + } + # Match bindings by identity, not a method-name prefix. Retain namespace + # function IDs for documentation; anonymous registry closures get path IDs. + function_names <- names(functions) + remaining_bindings <- 50000L + for (name in names(values)) { + value <- values[[name]] + if (isNamespace(value) || identical(value, ns) || identical(value, globalenv()) || + identical(value, baseenv())) { + next + } + size <- length(ls(value, all.names = TRUE)) + if (size > remaining_bindings) stop("Namespace exceeds registry budget") + remaining_bindings <- remaining_bindings - size + snapshots[name] <- list(member_snapshot(value, max_bindings = remaining_bindings + size, s7_modes = s7_modes)) + definitions[name] <- list(quote(new.env(parent = emptyenv()))) + methods <- character() + for (field in names(snapshots[[name]]$fields)) { + record <- member_binding(value, field) + fn <- record[[2L]] + if (identical(record[[1L]], "value") && is.environment(fn)) { + matches <- which(vapply(values, identical, logical(1L), fn)) + if (length(matches)) links[[name]][field] <- names(values)[[matches[[1L]]]] + } + if (!identical(record[[1L]], "value") || typeof(fn) != "closure") next + matches <- which(vapply(functions, identical, logical(1L), fn)) + key <- if (length(matches)) function_names[[matches[[1L]]]] else paste(name, field, sep = "$") + definitions[key] <- list(member_function_syntax(fn)) + # A static factory may also be addressed by its environment path. + definitions[paste(name, field, sep = "$")] <- list(as.name(key)) + if (identical(key, paste(name, field, sep = "$"))) definitions[key] <- list(member_function_syntax(fn)) + methods[field] <- key + } + registries[name] <- list(methods) + } + # Imported intrinsic summaries are allowed only for the actual provider's + # binding, not arbitrary functions with a matching local name. + intrinsics <- character() + imports <- parent.env(ns) + providers <- list(rlang = c( + "list2", "arg_match0", "arg_match", "try_fetch", + "is_character", "is_list", "is_bool", "abort" + ), S7 = member_s7_intrinsics, methods = member_methods_intrinsics) + for (provider in names(providers)) { + if (!provider %in% loadedNamespaces()) next + for (name in providers[[provider]]) { + if (name %in% names(definitions)) next + record <- member_binding(imports, name, materialize = TRUE) + source <- member_binding(asNamespace(provider), name, materialize = TRUE) + if (identical(record[[1L]], "value") && identical(source[[1L]], "value") && + identical(record[[2L]], source[[2L]])) { + intrinsics <- c(intrinsics, name) + } + } + } + list( + definitions = definitions, locations = list(), expressions = list(), + exports = exports, registries = registries, + 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, + s7_dependencies = member_s7_dependencies(s7_roots, package, s7_modes), + s4_dependencies = member_s4_dependencies(s4_classes, lapply(c( + lapply(s4_roots, function(value) value$s4_generator), s4_objects + ), function(class) structure(class$name, package = class$package))) + ) +} + +member_index_freeze <- function(index) { + value <- as.list(index) + value$cache <- NULL + value$generation <- digest::digest(value, algo = "sha256") + value$schema <- 1L + if (as.numeric(utils::object.size(value)) > 32 * 1024^2) stop("Namespace exceeds snapshot budget") + value +} + +member_index_thaw <- function(snapshot) { + if (!is.list(snapshot) || !identical(snapshot$schema, 1L)) { + return(NULL) + } + index <- list2env(snapshot, parent = emptyenv()) + index$cache <- new.env(parent = emptyenv()) + index +} + +member_prepare_package <- function(package, lib_paths = .libPaths()) { + .libPaths(lib_paths) + ns <- asNamespace(package) + input <- member_namespace_input(ns) + index <- member_package_index(input) + for (name in intersect(index$exports, names(index$roots))) { + record <- member_binding(ns, name) + value <- record[[2L]] + if (identical(record[[1L]], "value") && is.environment(value) && + "R6ClassGenerator" %in% attr(value, "class", exact = TRUE)) { + index$roots[name] <- list(member_r6_runtime_shape(value, index)) + } + } + index$r6_attached <- identical(package, "R6") + for (name in names(index$roots)) index$namespace_roots[paste(package, name, sep = "::")] <- list(index$roots[[name]]) + index$identity <- list( + package = package, path = find.package(package), + version = as.character(utils::packageVersion(package)), r = as.character(getRversion()) + ) + member_index_freeze(index) +} + +member_resolve_packages <- function(pkgs, lib_paths, prepare = TRUE) { + .libPaths(lib_paths) + packages <- resolve_attached_packages(pkgs) + snapshots <- list() + if (isTRUE(prepare)) { + for (package in setdiff(packages, startup_packages)) { + snapshots[package] <- list(tryCatch(member_prepare_package(package, lib_paths), + error = function(e) { + list( + schema = 1L, roots = list(), namespace_roots = list(), + package = package, generation = "", error = conditionMessage(e) + ) + } + )) + } + } + list( + packages = packages, members = snapshots, + requested = normalize_package_request(pkgs) + ) +} diff --git a/R/member-providers.R b/R/member-providers.R new file mode 100644 index 00000000..aab93816 --- /dev/null +++ b/R/member-providers.R @@ -0,0 +1,197 @@ +# All member providers share receiver inference and method identity. Metadata +# contains syntax only; resolving a signature never calls the selected member. +member_symbol_info <- function(label, value, key, index) { + if (!is.null(value$metadata)) { + package_index <- member_lookup(index$namespace_indices, value$metadata) + if (!is.null(package_index)) index <- package_index + } + if (!is.null(value$function_key)) key <- value$function_key + fn <- value$function_expr + if (is.null(fn)) fn <- member_definition(index$definitions, key) + if (!is.null(key) && key %in% index$native_factories) { + fn <- member_returned_function(fn)$fn + } + display <- if (identical(make.names(label), label) && + !label %in% c("TRUE", "FALSE", "NULL", "NA")) { + label + } else { + encodeString(label, quote = "`") + } + 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 + list( + label = label, signature = signature, function_id = key, + package = index$package, value = value + ) +} + +member_symbol <- function(uri, workspace, document, location) { + if (is.null(location)) { + return(NULL) + } + resolved <- member_resolve_cursor( + uri, workspace, document, + location$point, location$cursor, location$cursor$token + ) + if (is.null(resolved)) { + return(NULL) + } + value <- resolved$value + member_symbol_info(location$cursor$token, value, value$function_key, resolved$index) +} + +member_symbol_documentation <- function(workspace, symbol, uri) { + key <- symbol$function_id + if (is.null(symbol) || is.null(workspace$get_documentation) || !nzchar(symbol$package) || !is.character(key) || + length(key) != 1L || is.na(key)) { + return(NULL) + } + call_with_optional_uri(workspace$get_documentation, + key, symbol$package, + isf = TRUE, uri = uri + ) +} + +# Find a complete member token, even when hovering inside a backtick name. +# Recovery confirms that the member operator belongs to R syntax, not a quote +# or comment. Columns stay in code points until the provider returns LSP ranges. +member_hover_location <- function(document, point) { + if (point$row < 0L || point$row >= document$nline) { + return(NULL) + } + if (substr(document$line0(point$row), point$col + 1L, point$col + 1L) == "`") { + point$col <- point$col + 1L + } + cursor <- member_cursor(document, point) + if (is.null(cursor) || point$col < cursor$start || cursor$end <= cursor$start) { + return(NULL) + } + token <- substr(document$line0(point$row), cursor$start + 1L, cursor$end) + name <- tryCatch(member_name(parse(text = token)[[1L]]), error = function(e) NULL) + if (is.null(name) || !nzchar(name)) { + return(NULL) + } + cursor$token <- name + list( + point = list(row = point$row, col = cursor$end), cursor = cursor, + range = list( + start = list(row = point$row, col = cursor$start), + end = list(row = point$row, col = cursor$end) + ) + ) +} + +member_call_location <- function(document, point, call = document$detect_call(point), symbols = FALSE) { + opening <- call$opening + if (is.null(opening) || !check_r_region(document, point)) { + return(NULL) + } + row <- opening$row + col <- opening$col + # R permits whitespace/newlines between a member and its call parenthesis. + for (i in seq_len(129L)) { + prefix <- substr(document$line0(row), 1L, col) + col <- nchar(sub("[ \\t]+$", "", prefix)) + if (col > 0L) { + location <- member_hover_location(document, list(row = row, col = col)) + if (is.null(location) && symbols) location <- member_symbol_location(document, list(row = row, col = col)) + return(location) + } + row <- row - 1L + if (row < 0L || !check_r_region(document, list(row = row, col = 0L))) break + col <- nchar(document$line0(row)) + } + NULL +} + +# Reuse bounded cursor recovery for callable class bindings and aliases. This +# path is accepted by providers only when inference identifies a constructor. +member_symbol_location <- function(document, point) { + if (!check_scope(document$uri, document, point)) return(NULL) + token <- document$detect_token(point) + if (!token$accessor %in% c("", "::") || !nzchar(token$token)) return(NULL) + bounds <- token$range + row <- bounds$end$row + start <- bounds$start$col + end <- bounds$end$col + if (identical(token$accessor, "::")) { + start <- start + nchar(token$package) + 2L + bounds$start$col <- start + } + list(point = list(row = row, col = end), range = bounds, + cursor = list(operator_row = row, operator = start + 1L, start = start, end = end, + accessor = NULL, token = token$token, before = substr(document$line0(row), 1L, start))) +} + +member_constructor_symbol <- function(uri, workspace, document, location) { + if (is.null(location)) return(NULL) + symbol <- member_symbol(uri, workspace, document, location) + if (is.null(symbol$value$s7_generator)) return(NULL) + symbol +} + +member_constructor_arguments <- function(uri, workspace, document, point, token) { + location <- member_call_location(document, point, symbols = TRUE) + symbol <- member_constructor_symbol(uri, workspace, document, location) + if (is.null(symbol)) return(NULL) + args <- names(symbol$value$function_expr[[2L]]) + args <- setdiff(args, "...") + args <- args[match_with(args, token)] + lapply(seq_along(args), function(i) { + list(label = args[[i]], kind = CompletionItemKind$Variable, + detail = symbol$signature, sortText = sprintf("%s%03d", sort_prefixes$arg, i), + insertText = paste0(if (identical(make.names(args[[i]]), args[[i]])) args[[i]] else encodeString(args[[i]], quote = "`"), " = "), + insertTextFormat = InsertTextFormat$PlainText, data = list(type = "member", signature = symbol$signature)) + }) +} + +member_argument_location <- function(document, point, symbols = FALSE) { + if (!check_scope(document$uri, document, point)) { + return(NULL) + } + token <- document$detect_token(point) + end <- token$range$end + if (!nzchar(token$token) || !identical(token$accessor, "") || + !grepl("^[ \\t]*=(?!=)", substring(document$line0(end$row), end$col + 1L), perl = TRUE)) { + return(NULL) + } + location <- member_call_location(document, point, symbols = symbols) + if (is.null(location)) { + return(NULL) + } + location$parameter <- token$token + location$range <- token$range + location +} + +member_hover_reply <- function(id, uri, workspace, document, location) { + symbol <- member_symbol(uri, workspace, document, location) + doc <- member_symbol_documentation(workspace, symbol, uri) + signature <- symbol$signature + contents <- NULL + if (!is.null(location$parameter)) { + if (is.list(doc)) contents <- argument_hover_contents(doc, signature, location$parameter) + } else { + description <- if (is.character(doc)) { + doc + } else if (is.list(doc)) { + if (is.null(doc$markdown)) doc$description else doc$markdown + } + value <- symbol$value + detail <- if (!is.null(signature)) { + signature + } else if (isTRUE(value$known_literal)) { + paste(deparse(value$literal), collapse = "\n") + } else if (length(value$type)) paste(value$type, collapse = " | ") + contents <- c(if (!is.null(detail)) sprintf("```r\n%s\n```", detail), description) + } + if (is.null(contents)) { + return(Response$new(id)) + } + bounds <- location$range + Response$new(id, result = list(contents = contents, range = range( + document$to_lsp_position(bounds$start$row, bounds$start$col), + document$to_lsp_position(bounds$end$row, bounds$end$col) + ))) +} diff --git a/R/member-r6.R b/R/member-r6.R new file mode 100644 index 00000000..6db78184 --- /dev/null +++ b/R/member-r6.R @@ -0,0 +1,126 @@ +# Recognize declarative R6 definitions without creating an instance or running +# initialize/active functions. Only explicit package calls or verified imports +# qualify; a document function called R6Class has ordinary function semantics. +member_is_r6_call <- function(expr, index, bindings) { + if (!is.call(expr)) { + return(FALSE) + } + head <- expr[[1L]] + if (member_head(head, "::")) { + return(identical(member_name(head[[2L]]), "R6") && + identical(member_name(head[[3L]]), "R6Class")) + } + identical(member_name(head), "R6Class") && !"R6Class" %in% names(bindings) && + !"R6Class" %in% names(index$document_bindings) && + isTRUE(index$r6_attached) +} + +member_r6_shape <- function(expr, index, bindings, budget) { + args <- as.list(expr)[-1L] + active <- args$active + inherited <- member_value() + if (!is.null(args$inherit)) { + generator <- member_infer(args$inherit, index, bindings, budget = budget) + inherited <- generator$fields$new$result_shape + } + fields <- if (is.null(inherited$fields)) list() else inherited$fields + # R6's super environment contains ancestor methods and active properties, + # including private methods, but does not expose ancestor data fields. + methods <- c(inherited$fields, inherited$r6_private$fields) + methods <- Filter(function(value) !is.null(value$function_expr) || identical(value$reason, "active_property"), methods) + super <- member_value(type = "environment", fields = methods) + # Private fields are available inside methods, outside the public surface. + private <- if (is.null(inherited$r6_private$fields)) list() else inherited$r6_private$fields + own <- list(public = character(), private = character()) + for (section in c("private", "public")) { + node <- args[[section]] + if (!member_head(node, "list")) next + values <- as.list(node)[-1L] + for (name in names(values)) { + value <- member_infer(values[[name]], index, bindings, budget = budget) + if (!is.null(value$function_expr)) { + value$receiver_name <- "self" + value$closure$self <- NULL + value$closure$super <- super + } + if (section == "public") { + fields[name] <- list(value) + } else { + private[name] <- list(value) + } + own[[section]] <- c(own[[section]], name) + } + } + if (member_head(active, "list")) { + for (name in names(as.list(active)[-1L])) { + fields[name] <- list(member_value(reason = "active_property")) + } + } + private_value <- member_value(type = "environment", fields = private) + for (name in own$public) { + if (!is.null(fields[[name]]$function_expr)) fields[[name]]$closure$private <- private_value + } + for (name in own$private) { + if (!is.null(private[[name]]$function_expr)) private[[name]]$closure$private <- private_value + } + instance <- member_value(type = "environment", fields = fields, open = TRUE, + r6_private = member_value(type = "environment", fields = private), r6_super = super) + member_value(type = "environment", fields = list(new = member_value( + type = "function", result_shape = instance + ))) +} + +member_r6_context <- function(expr, index, bindings, budget) { + instance <- member_r6_shape(expr, index, bindings, budget)$fields$new$result_shape + super <- instance$r6_super + super$r6_self <- instance + private <- instance$r6_private + private$r6_self <- instance + list(self = instance, super = super, private = private) +} + +member_r6_runtime_shape <- function(generator, index, trail = list()) { + if (length(trail) > 16L || any(vapply(trail, identical, logical(1L), generator))) { + return(member_value(reason = "inheritance_cycle")) + } + get_plain <- function(name) member_binding(generator, name)[[2L]] + public <- get_plain("public_methods") + public_fields <- get_plain("public_fields") + private_methods <- get_plain("private_methods") + private_fields <- get_plain("private_fields") + active <- get_plain("active") + inherited <- get_plain("inherit") + if (!is.list(public) || is.object(public)) { + return(member_value(reason = "unsupported_r6")) + } + convert <- function(values) { + as.call(c(list(as.name("list")), lapply(values, function(x) { + if (typeof(x) == "closure") { + member_function_syntax(x) + } else if (!is.object(x) && is.atomic(x) && length(x) <= 100L) { + x + } else { + as.name(".__unknown_field__") + } + }))) + } + bindings <- list() + # Inheritance may be an expression resolved in the generator's parent scope. + # Read a direct binding only; never evaluate get_inherit() or an expression. + if (is.symbol(inherited)) { + scope <- get_plain("parent_env") + if (is.environment(scope)) { + record <- member_binding(scope, as.character(inherited)) + parent <- record[[2L]] + if (identical(record[[1L]], "value") && is.environment(parent)) { + bindings$.__r6_parent__ <- member_r6_runtime_shape(parent, index, c(trail, list(generator))) + } + } + } + expr <- as.call(list(as.call(list(as.name("::"), as.name("R6"), as.name("R6Class"))), + classname = "inspected", public = convert(c(public_fields, public)), + private = convert(c(private_fields, private_methods)), + active = convert(active), inherit = as.name(".__r6_parent__") + )) + member_r6_shape(expr, index, bindings, NULL) +} diff --git a/R/member-s4.R b/R/member-s4.R new file mode 100644 index 00000000..f28d8b2f --- /dev/null +++ b/R/member-s4.R @@ -0,0 +1,338 @@ +# S4 slot declarations are separate from dollar members. Read syntax and class +# metadata only: never call new(), initialize(), validity or slot accessors. +member_methods_intrinsics <- c("setClass", "setClassUnion", "representation", "prototype", "new", "slot") + +member_s4_unshadowed <- function(name, index, bindings) { + if (name %in% names(bindings)) return(FALSE) + at <- bindings$.__member_position__ + history <- member_lookup(index$document_bindings, name) + if (length(history) && (is.null(at) || any(vapply(history, function(item) { + member_before(item$end, at) + }, logical(1L))))) return(FALSE) + if (name %in% names(index$definitions) && is.null(index$document_bindings)) return(FALSE) + attached <- member_lookup(index$attached_roots, name) + is.null(attached) || (!is.null(attached$metadata) && attached$metadata %in% c("base", "methods")) +} + +member_s4_method <- function(expr, index, bindings) { + if (!is.call(expr)) return(NULL) + head <- expr[[1L]] + if (member_head(head, "::")) { + if (identical(member_name(head[[2L]]), "methods")) return(member_name(head[[3L]])) + return(NULL) + } + name <- member_name(head) + if (is.null(name) || !name %in% member_methods_intrinsics || !member_s4_unshadowed(name, index, bindings)) return(NULL) + if (isTRUE(index$methods_attached) || name %in% index$intrinsics) name else NULL +} + +member_s4_literal_call <- function(expr, name, index, bindings) { + if (!is.call(expr)) return(FALSE) + head <- expr[[1L]] + if (member_head(head, "::")) { + return(identical(member_name(head[[2L]]), "base") && identical(member_name(head[[3L]]), name)) + } + member_head(expr, name) && member_s4_unshadowed(name, index, bindings) +} + +member_s4_strings <- function(expr, index, bindings) { + if (is.character(expr)) return(expr) + if (member_s4_literal_call(expr, "c", index, bindings)) { + args <- as.list(expr)[-1L] + if (all(vapply(args, is.character, logical(1L)))) return(as.character(unlist(args))) + } + character() +} + +member_s4_arguments <- function(expr, first = "Class") { + args <- as.list(expr)[-1L] + for (i in seq_along(args)) { + if (identical(args[[i]], quote(expr = ))) args[[i]] <- as.name(".__unknown_s4_argument__") + } + if (is.null(names(args))) names(args) <- rep("", length(args)) + if (length(args) && (is.null(names(args)) || !nzchar(names(args)[[1L]]))) { + names(args)[[1L]] <- first + } + args +} + +member_s4_recipe <- function(expr, index, bindings) { + if (member_head(expr, "<-") || member_head(expr, "=")) expr <- expr[[3L]] + method <- member_s4_method(expr, index, bindings) + if (is.null(method) || !method %in% c("setClass", "setClassUnion")) return(NULL) + args <- member_s4_arguments(expr, if (method == "setClassUnion") "name" else "Class") + key <- if (method == "setClassUnion") "name" else "Class" + name <- args[[key]] + if (!is.character(name) || length(name) != 1L || !nzchar(name)) return(NULL) + if (method == "setClassUnion") { + members <- if (!is.null(args$members)) args$members else if (length(args) >= 2L) args[[2L]] + types <- member_s4_strings(members, index, bindings) + return(list(name = name, union = as.list(types), virtual = TRUE, complete = length(types) <= 256L)) + } + slots <- list() + contains <- member_s4_strings(args$contains, index, bindings) + complete <- is.null(args$contains) || length(contains) > 0L || identical(args$contains, character()) || + (member_s4_literal_call(args$contains, "c", index, bindings) && length(args$contains) == 1L) + declaration <- function(node, legacy = FALSE) { + if (is.null(node) || identical(node, character())) return() + values <- if (is.character(node)) { + as.list(node) + } else if (member_s4_literal_call(node, "c", index, bindings) || member_s4_literal_call(node, "list", index, bindings) || + identical(member_s4_method(node, index, bindings), "representation")) { + as.list(node)[-1L] + } else { + complete <<- FALSE + return() + } + if (length(values) > 256L) { + complete <<- FALSE + return() + } + for (i in seq_along(values)) { + key <- if (is.null(names(values))) "" else names(values)[[i]] + if (identical(values[[i]], quote(expr = ))) { + complete <<- FALSE + next + } + type <- values[[i]] + if (!is.character(type) || length(type) != 1L || !nzchar(type)) { + complete <<- FALSE + } else if (nzchar(key)) { + slots[key] <<- list(type) + } else if (legacy) { + contains <<- union(contains, type) + } else { + complete <<- FALSE + } + } + } + representation <- args$representation + if (is.null(representation) && length(args) >= 2L && !nzchar(names(args)[[2L]])) representation <- args[[2L]] + declaration(representation, TRUE) + declaration(args$slots) + if (length(contains) > 32L) complete <- FALSE + prototype <- args$prototype + defaults <- list() + if (member_s4_literal_call(prototype, "list", index, bindings) || identical(member_s4_method(prototype, index, bindings), "prototype")) { + defaults <- as.list(prototype)[-1L] + } + list(name = name, slots = slots, contains = setdiff(contains, "VIRTUAL"), + virtual = "VIRTUAL" %in% contains, defaults = defaults, complete = complete) +} + +member_s4_effect <- function(expr, index, bindings) { + recipe <- member_s4_recipe(expr, index, bindings) + if (!is.null(recipe)) bindings$.__s4_classes__[recipe$name] <- list(recipe) + bindings +} + +member_s4_descriptor <- function(name, index, bindings, package = NULL) { + if (!is.null(package)) { + if (identical(package, index$package)) return(member_lookup(index$s4_classes, name)) + descriptor <- member_lookup(member_lookup(index$namespace_indices, package)$s4_classes, name) + if (!is.null(descriptor)) return(descriptor) + return(member_lookup(member_lookup(index$s4_dependencies, package), name)) + } + local <- member_lookup(bindings$.__s4_classes__, name) + if (!is.null(local)) return(local) + at <- bindings$.__member_position__ + if (is.null(at)) at <- c(Inf, Inf) + declarations <- member_lookup(index$document_s4, name) + for (item in rev(declarations)) { + if (!member_before(item$end, at)) next + env <- bindings + env$.__member_position__ <- item$start + recipe <- member_s4_recipe(item$expr, index, env) + if (!is.null(recipe)) return(recipe) + } + if (is.null(index$document_bindings)) return(member_lookup(index$s4_classes, name)) + member_lookup(index$attached_s4, name) +} + +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)) { + budget$exhausted <- TRUE + return(member_value(reason = "budget")) + } + } + identity <- paste(package, name, sep = "::") + if (length(trail) > 32L || identity %in% trail) return(member_value(reason = "s4_cycle")) + descriptor <- member_s4_descriptor(name, index, bindings, package) + if (is.null(descriptor) || identical(descriptor$complete, FALSE)) return(member_value(reason = "unknown_s4_class")) + trail <- c(trail, identity) + if (!is.null(descriptor$union)) { + if (!length(descriptor$union)) return(member_value(reason = "unknown_s4_union")) + return(Reduce(member_join, lapply(descriptor$union, function(type) { + owner <- attr(type, "package", exact = TRUE) + member_s4_shape(as.character(type), index, bindings, if (is.null(owner)) package else owner, trail, budget) + }))) + } + slots <- defaults <- list() + for (parent in descriptor$contains) { + # R's built-in storage classes contribute the data part of an S4 + # extension, rather than a user-defined slot inheritance recipe. + if (parent %in% c("numeric", "integer", "double", "logical", "character", "complex", "raw", "list", "expression", + "function", "language", "matrix", "array")) { + slots[".Data"] <- list(parent) + next + } + if (parent %in% c("environment", "externalptr")) { + slots[".xData"] <- list(parent) + next + } + inherited <- member_s4_shape(parent, index, bindings, package, trail, budget) + if (is.null(inherited$slot_types)) return(member_value(reason = "unknown_s4_parent")) + slots <- utils::modifyList(slots, inherited$slot_types) + if (!is.null(inherited$slots)) defaults <- utils::modifyList(defaults, inherited$slots) + } + slots <- utils::modifyList(slots, descriptor$slots) + if (length(slots) > 256L) return(member_value(reason = "s4_slot_limit")) + for (slot in intersect(names(descriptor$defaults), names(slots))) { + # Prototype declarations supply syntax, not evaluated default objects. + if (identical(descriptor$defaults[[slot]], quote(expr = ))) next + defaults[slot] <- list(member_value(binding_expr = descriptor$defaults[[slot]], binding_env = bindings)) + } + owner <- if (is.null(descriptor$package)) package else descriptor$package + member_value(type = name, s4_class = list(name = name, package = owner), + slot_types = slots, slots = defaults) +} + +member_s4_types <- function(types, package = NULL) { + owners <- attr(types, "package", exact = TRUE) + lapply(seq_along(types), function(i) { + type <- types[[i]] + owner <- if (length(owners) == length(types)) owners[[i]] else if (length(owners) == 1L) owners else package + if (!is.null(owner) && nzchar(owner)) attr(type, "package") <- owner + type + }) +} + +member_s4_join_types <- function(a, b, owner_a = NULL, owner_b = NULL) { + types <- unique(c(member_s4_types(a, owner_a), member_s4_types(b, owner_b))) + out <- vapply(types, as.character, character(1L)) + owners <- vapply(types, function(type) { + owner <- attr(type, "package", exact = TRUE) + if (is.null(owner)) "" else owner + }, character(1L)) + if (any(nzchar(owners))) attr(out, "package") <- owners + out +} + +member_s4_slot <- function(value, name, index, bindings, budget = NULL) { + type <- member_lookup(value$slot_types, name) + if (is.null(type)) return(member_value(reason = "unknown_s4_slot")) + actual <- member_lookup(value$slots, name) + if (!is.null(actual$binding_expr)) { + if (is.null(budget)) { + budget <- new.env(parent = emptyenv()) + budget$remaining <- 20000L + } + trail <- budget$s4_slots + key <- paste(value$s4_class$package, value$s4_class$name, name, sep = "::") + if (key %in% trail || length(trail) >= 64L) return(member_value(reason = "s4_cycle")) + budget$s4_slots <- c(trail, key) + on.exit(budget$s4_slots <- trail) + actual <- member_infer(actual$binding_expr, index, actual$binding_env, budget = budget) + } + if (!is.null(actual) && (length(actual$type) || !is.null(actual$function_expr))) return(actual) + shapes <- lapply(member_s4_types(type, value$s4_class$package), function(class) { + package <- attr(class, "package", exact = TRUE) + class <- as.character(class) + types <- c(numeric = "double", integer = "integer", character = "character", logical = "logical", + complex = "complex", raw = "raw", list = "list", environment = "environment", "function" = "function") + if (class %in% names(types)) return(member_value(type = unname(types[[class]]))) + nested <- member_s4_shape(class, index, bindings, package, budget = budget) + if (!is.null(nested$slot_types)) return(nested) + member_value(type = if (class %in% names(types)) unname(types[[class]]) else if (class != "ANY") class) + }) + Reduce(member_join, shapes) +} + +member_s4_construct <- function(class, actuals, index, bindings, budget = NULL) { + if (!is.null(class$recipe)) bindings$.__s4_classes__[class$name] <- list(class$recipe) + descriptor <- member_s4_descriptor(class$name, index, bindings, class$package) + if (isTRUE(descriptor$virtual)) return(member_value(reason = "virtual_s4_class")) + value <- member_s4_shape(class$name, index, bindings, class$package, budget = budget) + for (slot in intersect(names(actuals), names(value$slot_types))) value$slots[slot] <- list(actuals[[slot]]) + value +} + +member_s4_runtime_descriptor <- function(value) { + name <- attr(value, "className", exact = TRUE) + slots <- attr(value, "slots", exact = TRUE) + if (!is.character(name) || length(name) != 1L || !is.list(slots) || length(slots) > 256L) return(NULL) + if ("ClassUnionRepresentation" %in% attr(value, "class", exact = TRUE)) { + subclasses <- attr(value, "subclasses", exact = TRUE) + if (length(subclasses) > 256L) return(NULL) + types <- lapply(subclasses, function(extension) attr(extension, "subClass", exact = TRUE)) + if (!all(vapply(types, function(type) is.character(type) && length(type) == 1L, logical(1L)))) return(NULL) + return(list(name = as.character(name), package = attr(name, "package", exact = TRUE), union = types, virtual = TRUE)) + } + slots <- lapply(slots, function(type) { + if (is.character(type) && length(type) == 1L) type else "ANY" + }) + # Installed descriptors already include inherited slots. Their prototypes + # and initialization methods are not read or invoked to guess slot values. + list(name = as.character(name), package = attr(name, "package", exact = TRUE), slots = slots, contains = character(), + virtual = isTRUE(attr(value, "virtual", exact = TRUE)), complete = TRUE) +} + +member_s4_dependencies <- function(classes, references = list()) { + out <- list() + queue <- c(classes, list(list(slots = references))) + seen <- character() + for (pass in seq_len(16L)) { + next_queue <- list() + for (descriptor in queue) { + for (type in c(descriptor$slots, descriptor$union)) { + package <- attr(type, "package", exact = TRUE) + if (!is.character(package) || length(package) != 1L || !package %in% loadedNamespaces()) next + key <- paste(package, type, sep = "::") + if (key %in% seen || length(seen) >= 256L) next + seen <- c(seen, key) + record <- member_binding(asNamespace(package), paste0(".__C__", type), materialize = TRUE) + value <- record[[2L]] + if (!identical(record[[1L]], "value") || !isS4(value)) next + nested <- member_s4_runtime_descriptor(value) + if (is.null(nested)) next + out[[package]][nested$name] <- list(nested) + next_queue[[length(next_queue) + 1L]] <- nested + } + } + if (!length(next_queue)) break + queue <- next_queue + } + out +} + +member_s4_call <- function(expr, index, bindings, budget) { + method <- member_s4_method(expr, index, bindings) + if (is.null(method)) return(NULL) + if (method == "setClass") { + recipe <- member_s4_recipe(expr, index, bindings) + return(if (is.null(recipe)) member_value() else member_value( + type = "function", s4_generator = list(name = recipe$name, recipe = recipe) + )) + } + if (method == "slot") { + args <- member_s4_arguments(expr, "object") + name <- if (!is.null(args$name)) args$name else if (length(args) >= 2L) args[[2L]] + if (!is.character(name) || length(name) != 1L) return(member_value()) + value <- member_infer(args$object, index, bindings, budget = budget) + return(member_s4_slot(value, name, index, bindings, budget)) + } + if (method != "new") return(NULL) + args <- member_s4_arguments(expr) + class <- member_infer(args$Class, index, bindings, budget = budget) + if (isTRUE(class$known_literal) && is.character(class$literal) && length(class$literal) == 1L) { + target <- list(name = class$literal) + } else { + return(member_value(reason = "dynamic_s4_class")) + } + actuals <- lapply(args[names(args) != "Class"], function(arg) { + member_infer(arg, index, bindings, budget = budget) + }) + member_s4_construct(target, actuals, index, bindings, budget) +} diff --git a/R/member-s7.R b/R/member-s7.R new file mode 100644 index 00000000..0469e192 --- /dev/null +++ b/R/member-s7.R @@ -0,0 +1,647 @@ +# S7 descriptors are read as inert data. Source declarations are summarized +# from syntax; constructors, validators, getters and defaults are never called. +member_s7_intrinsics <- c("new_class", "new_property", "new_union", "new_object", "prop", "set_props", + "as_class", "new_external_class", "new_S3_class", "deprecated_class", "deprecated_property", ":=") + + +# Derive semantics in the metadata worker from the installed implementation. +# Unknown implementations keep the older, conservative summaries. No probe +# constructs an object or invokes package callbacks. +member_s7_capabilities <- function() { + if (!"S7" %in% loadedNamespaces()) return(list()) + ns <- asNamespace("S7") + read <- function(name) { + record <- member_binding(ns, name, materialize = TRUE) + if (identical(record[[1L]], "value") && typeof(record[[2L]]) == "closure") record[[2L]] + } + uses <- function(name, symbol) { + fn <- read(name) + !is.null(fn) && symbol %in% all.names(body(fn)) + } + args_fn <- read("constructor_args") + first <- function(name) names(formals(read(name)))[1L] + list(forward = uses("new_constructor", "constructor_forward"), + overrides = !is.null(args_fn) && !uses("constructor_args", "setdiff"), + class_ref = uses("new_object", "get_class_ref"), + lists = uses("set_props", "collect_dots"), + s4 = uses("new_constructor", "is_S4_class"), + bind = uses(":=", "S7_eval_bare_"), + union = uses("|.S7_class", "new_union"), + exports = getNamespaceExports(ns), + object = first("set_props"), parent = first("new_object")) +} + +member_s7_modes <- function(index) { + if (!is.null(index$s7_capabilities)) return(index$s7_capabilities) + member_lookup(index$namespace_indices, "S7")$s7_capabilities +} + +# := is a declaration only when its binding belongs to S7. Other packages +# use the same spelling with unrelated semantics. +member_s7_bind <- function(expr, index, bindings) { + if (!member_head(expr, ":=") || length(expr) != 3L || !is.symbol(expr[[2L]]) || + !is.call(expr[[3L]]) || !isTRUE(member_s7_modes(index)$bind) || + !identical(member_s7_method(expr, index, bindings), ":=")) return(NULL) + rhs <- expr[[3L]] + if ("name" %in% names(rhs)) return(NULL) + rhs$name <- as.character(expr[[2L]]) + call("<-", expr[[2L]], rhs) +} + +member_s7_value <- function(..., s7 = FALSE, s7_descriptor = NULL, s7_generator = NULL, s7_property = NULL) { + value <- member_value(...) + value$s7 <- s7 + value$s7_descriptor <- s7_descriptor + value$s7_generator <- s7_generator + value$s7_property <- s7_property + value +} + +member_s7_method <- function(expr, index, bindings) { + if (!is.call(expr)) return(NULL) + head <- expr[[1L]] + if (member_head(head, "::")) { + if (identical(member_name(head[[2L]]), "S7")) return(member_name(head[[3L]])) + return(NULL) + } + name <- member_name(head) + if (is.null(name) || !name %in% member_s7_intrinsics || name %in% names(bindings)) return(NULL) + at <- bindings$.__member_position__ + history <- member_lookup(index$document_bindings, name) + if (length(history) && (is.null(at) || any(vapply(history, function(item) member_before(item$end, at), logical(1L))))) return(NULL) + attached <- member_lookup(index$attached_roots, name) + if ((!is.null(attached$metadata) && !identical(attached$metadata, "S7")) || + (is.null(index$document_bindings) && name %in% names(index$definitions) && !identical(index$package, "S7"))) return(NULL) + if (isTRUE(index$s7_attached) || name %in% index$intrinsics || identical(attached$metadata, "S7")) name else NULL +} + +# Exact matching precedes partial matching, and positional/partial matching +# stops at dots, as in R. Keep unmatched dots in order for parent forwarding. +member_s7_match <- function(args, keys) { + supplied <- names(args) + if (is.null(supplied)) supplied <- rep("", length(args)) + dots <- match("...", keys, nomatch = length(keys) + 1L) + before <- keys[seq_len(dots - 1L)] + result <- list() + used <- rep(FALSE, length(args)) + for (i in which(nzchar(supplied) & supplied %in% setdiff(keys, "..."))) { + key <- supplied[[i]] + if (key %in% names(result)) return(NULL) + result[key] <- args[i] + used[[i]] <- TRUE + } + for (i in which(nzchar(supplied) & !used)) { + candidates <- before[startsWith(before, supplied[[i]])] + if (length(candidates) > 1L || (length(candidates) == 1L && candidates %in% names(result))) return(NULL) + if (length(candidates) == 1L) { + result[candidates] <- args[i] + used[[i]] <- TRUE + } + } + available <- setdiff(before, names(result)) + positional <- which(!nzchar(supplied) & !used) + for (i in seq_len(min(length(positional), length(available)))) { + result[available[[i]]] <- args[positional[[i]]] + used[[positional[[i]]]] <- TRUE + } + if (any(!used) && !"..." %in% keys) return(NULL) + list(args = result, dots = args[!used]) +} + +member_s7_arguments <- function(expr, keys) { + args <- as.list(expr)[-1L] + if (any(vapply(args, function(arg) identical(arg, quote(expr = )), logical(1L)))) return(NULL) + member_s7_match(args, keys)$args +} + +member_s7_function <- function(formals) { + syntax <- function(node) { + if (missing(node)) return(quote(expr = )) + if (typeof(node) == "closure") { + name <- attr(node, "name", exact = TRUE) + return(if (is.character(name) && length(name) == 1L) as.name(name) else as.name(".__unknown_s7_default__")) + } + if (is.call(node)) return(as.call(lapply(as.list(node), syntax))) + node + } + formals <- lapply(formals, function(node) if (identical(node, quote(expr = ))) quote(expr = ) else syntax(node)) + as.call(list(as.name("function"), as.pairlist(formals), NULL)) +} + +member_s7_type <- function(descriptor) { + if (identical(descriptor$kind, "union")) return(unique(unlist(lapply(descriptor$classes, member_s7_type)))) + if (identical(descriptor$kind, "any")) return("ANY") + descriptor$name +} + +member_s7_shape <- function(descriptor, bindings = list(), depth = 0L) { + if (depth >= 32L) return(member_value(reason = "s7_recursion")) + if (is.null(descriptor)) return(member_value(reason = "unknown_s7_class")) + if (identical(descriptor$kind, "union")) { + shapes <- lapply(descriptor$classes, member_s7_shape, bindings, depth + 1L) + return(if (length(shapes)) Reduce(member_join, shapes) else member_value()) + } + if (identical(descriptor$kind, "s4")) { + return(member_value(type = descriptor$name, slot_types = descriptor$slots, + s4_class = list(name = descriptor$name, package = descriptor$package))) + } + if (!identical(descriptor$kind, "class")) { + return(member_s7_value(type = if (!identical(descriptor$kind, "any")) descriptor$name, + s7_descriptor = if (identical(descriptor$kind, "external")) descriptor)) + } + properties <- descriptor$properties + slots <- lapply(properties, function(property) { + value <- member_s7_shape(property$class, bindings, depth + 1L) + if (!property$getter && !property$setter && !is.null(property$default)) { + value$binding_expr <- property$default + value$binding_env <- bindings + } + value + }) + types <- lapply(properties, function(property) { + type <- member_s7_type(property$class) + if (length(type)) type else "ANY" + }) + member_s7_value(type = descriptor$name, slots = slots, slot_types = types, s7 = TRUE, + s7_descriptor = descriptor) +} + +member_s7_generator <- function(descriptor, bindings = list(), depth = 0L) { + if (depth >= 32L) return(member_value(reason = "s7_recursion")) + shape <- member_s7_shape(descriptor, bindings, depth) + constructor <- member_s7_value(type = "function", function_expr = descriptor$constructor, + closure = bindings, s7_generator = descriptor) + # Class objects themselves expose descriptor properties via @. + constructor$slots <- list(name = member_literal(descriptor$name), + parent = if (!is.null(descriptor$parent)) member_s7_generator(descriptor$parent, bindings, depth + 1L) else member_literal(NULL), + package = member_literal(descriptor$package), abstract = member_literal(isTRUE(descriptor$abstract)), + properties = member_value(type = "list", fields = shape$slots), + constructor = member_s7_value(type = "function", function_expr = descriptor$constructor, + closure = bindings, s7_generator = if (isTRUE(descriptor$modes$class_ref)) descriptor), + validator = member_value(type = "function")) + constructor$slot_types <- lapply(constructor$slots, function(value) if (length(value$type)) value$type else "ANY") + constructor$s7 <- TRUE + constructor$s7_descriptor <- descriptor + constructor +} + +member_s7_default <- function(descriptor) { + if (identical(descriptor$kind, "union")) { + return(if (length(descriptor$classes)) member_s7_default(descriptor$classes[[1L]])) + } + if (identical(descriptor$kind, "external") || isTRUE(descriptor$external)) { + ref <- call("::", as.name(descriptor$package), as.name(descriptor$name)) + return(as.call(list(as.call(list(quote(S7::as_class), ref))))) + } + if (identical(descriptor$kind, "s4")) return(as.call(list(call("::", as.name("methods"), as.name("new")), descriptor$name))) + if (identical(descriptor$kind, "class")) { + ref <- if (is.null(descriptor$package)) as.name(descriptor$name) else + call("::", as.name(descriptor$package), as.name(descriptor$name)) + return(as.call(list(ref))) + } + descriptor$default +} + +member_s7_call <- function(expr, index, bindings, budget, method = member_s7_method(expr, index, bindings)) { + if (is.null(method) || !method %in% member_s7_intrinsics) return(NULL) + if (method %in% c("new_external_class", "deprecated_class", "deprecated_property", ":=") && + !method %in% member_s7_modes(index)$exports) return(member_value(reason = "unavailable_s7_api")) + nesting <- budget$s7_depth + if (is.null(nesting)) nesting <- 0L + if (nesting >= 32L) return(member_value(reason = "s7_recursion")) + budget$s7_depth <- nesting + 1L + on.exit(budget$s7_depth <- nesting) + infer <- function(node) member_infer(node, index, bindings, budget = budget) + modes <- member_s7_modes(index) + if (method == "as_class") { + args <- member_s7_arguments(expr, c("x", "arg")) + if (is.null(args)) return(member_value()) + value <- infer(args$x) + descriptor <- member_s7_spec(value, index, bindings, budget) + return(if (is.null(descriptor)) member_value() else if (descriptor$kind == "class") + member_s7_generator(descriptor, bindings) else member_s7_value(s7_descriptor = descriptor)) + } + if (method == "new_external_class") { + args <- member_s7_arguments(expr, c("package", "name", "version")) + if (is.null(args) || !is.character(args$package) || length(args$package) != 1L || + !is.character(args$name) || length(args$name) != 1L) return(member_value()) + return(member_s7_value(type = "S7_external_class", s7_descriptor = c(list(kind = "external"), args))) + } + if (method == "new_S3_class") { + args <- member_s7_arguments(expr, c("class", "constructor", "validator", "default")) + if (is.null(args) || !is.character(args$class) || !length(args$class)) return(member_value()) + constructor <- infer(args$constructor)$function_expr + default <- args$default + if (member_head(default, "quote")) default <- default[[2L]] + return(member_s7_value(type = "S7_S3_class", s7_descriptor = list(kind = "base", name = args$class, + constructor = constructor, custom = TRUE, s3 = TRUE, default = default))) + } + if (method == "deprecated_class") { + args <- as.list(expr)[-1L] + args[c("when", "new", "method")] <- NULL + return(member_s7_call(as.call(c(list(quote(S7::new_class)), args)), index, bindings, budget, "new_class")) + } + if (method == "deprecated_property") { + args <- member_s7_arguments(expr, c("old", "new", "when", "method", "class", "default", "validator")) + if (is.null(args) || !is.character(args$old) || length(args$old) != 1L) return(member_value()) + default <- args$default + if (member_head(default, "quote")) default <- default[[2L]] + if (is.null(default) && is.character(args$new) && length(args$new) == 1L) default <- as.name(args$new) + return(member_s7_value(type = "S7_property", s7_property = list(name = args$old, + class = if (is.null(args$class)) list(kind = "any") else member_s7_spec(infer(args$class), index, bindings, budget, resolve = FALSE), + default = default, getter = !is.null(args$new), setter = !is.null(args$new), alias = args$new))) + } + if (method == "new_union") { + values <- lapply(as.list(expr)[-1L], infer) + classes <- lapply(values, function(value) member_s7_spec(value, index, bindings, budget)) + if (!length(classes) || length(classes) > 256L || any(vapply(classes, is.null, logical(1L)))) return(member_value()) + return(member_s7_value(type = "S7_union", s7_descriptor = list(kind = "union", classes = classes))) + } + if (method == "new_property") { + args <- member_s7_arguments(expr, c("class", "getter", "setter", "validator", "default", "name")) + if (is.null(args)) return(member_value()) + class <- if (is.null(args$class)) list(kind = "any") else member_s7_spec(infer(args$class), index, bindings, budget, resolve = FALSE) + default <- args$default + if (member_head(default, "quote") && length(default) == 2L) default <- default[[2L]] + getter <- if (!is.null(args$getter)) infer(args$getter) + setter <- if (!is.null(args$setter)) infer(args$setter) + return(member_s7_value(type = "S7_property", s7_property = list(class = class, default = default, + getter = !is.null(getter) && !identical(getter$type, "NULL"), + setter = !is.null(setter) && !identical(setter$type, "NULL"), name = member_name(args$name)))) + } + if (method == "new_class") { + args <- member_s7_arguments(expr, c("name", "parent", "package", "properties", "abstract", "constructor", "validator")) + if (is.null(args) || !is.character(args$name) || length(args$name) != 1L || !nzchar(args$name)) return(member_value()) + parent <- if (is.null(args$parent)) NULL else member_s7_spec(infer(args$parent), index, bindings, budget) + if (!is.null(args$parent) && (is.null(parent) || identical(parent$kind, "external"))) return(member_value(reason = "unknown_s7_parent")) + if (identical(parent$kind, "s4") && !isTRUE(modes$s4)) return(member_value(reason = "unsupported_s7_parent")) + abstract <- if (is.null(args$abstract)) FALSE else infer(args$abstract)$literal + if (!is.logical(abstract) || length(abstract) != 1L || is.na(abstract)) return(member_value(reason = "dynamic_s7_abstract")) + package <- if (is.null(args$package)) index$package else if (is.character(args$package)) args$package + own <- character() + properties <- if (is.null(parent$properties)) list() else parent$properties + if (!is.null(args$properties)) { + value <- infer(args$properties) + values <- value$elements + if (!identical(value$type, "list") || length(values) > 256L) return(member_value(reason = "dynamic_s7_properties")) + keys <- names(values) + if (is.null(keys)) keys <- rep("", length(values)) + for (i in seq_along(values)) { + property <- values[[i]]$s7_property + if (is.null(property)) property <- list(class = member_s7_spec(values[[i]], index, bindings, budget, resolve = FALSE), getter = FALSE, setter = FALSE) + name <- if (nzchar(keys[[i]])) keys[[i]] else property$name + if (is.null(name) || !nzchar(name) || name %in% keys[seq_len(i - 1L)]) return(member_value(reason = "dynamic_s7_properties")) + keys[[i]] <- name + properties[name] <- list(property) + own <- c(own, name) + } + } + if (length(properties) > 256L) return(member_value(reason = "s7_property_limit")) + custom <- !is.null(args$constructor) && !identical(infer(args$constructor)$type, "NULL") + constructor <- if (custom) infer(args$constructor)$function_expr + if (custom && is.null(constructor)) return(member_value(reason = "dynamic_s7_constructor")) + if (!custom) { + root <- is.null(parent) || identical(parent$name, "S7_object") || isTRUE(parent$abstract) || identical(parent$kind, "s4") + forward <- !root && isTRUE(modes$forward) && ((isTRUE(parent$custom) && (identical(parent$kind, "class") || isTRUE(parent$s3))) || isTRUE(parent$external) || + (!is.null(package) && !is.null(parent$package) && !identical(package, parent$package))) + formals <- if (root) list() else if (forward) alist(... = ) else as.list(parent$constructor[[2L]]) + args_own <- if (root) names(properties) else if (isTRUE(modes$overrides)) own else setdiff(own, names(parent$properties)) + for (name in args_own) { + property <- properties[[name]] + if (property$getter && !property$setter) next + default <- if (!is.null(property$default)) property$default else member_s7_default(property$class) + formals[name] <- list(if (is.null(default) && is.null(property$class)) quote(expr = ) else default) + } + constructor <- member_s7_function(formals) + } + descriptor <- list(kind = "class", name = args$name, parent = parent, properties = properties, + package = package, abstract = abstract, + constructor = constructor, custom = custom, own = own, forward = if (!custom) forward else FALSE, + modes = modes[c("class_ref", "overrides")]) + return(member_s7_generator(descriptor, bindings)) + } + if (method == "prop") { + args <- member_s7_arguments(expr, c("object", "name")) + if (is.null(args)) return(member_value()) + return(member_slot(infer(args$object), member_name(args$name), index, bindings, budget)) + } + if (method %in% c("set_props", "new_object")) { + first <- if (method == "set_props") modes$object else modes$parent + if (is.null(first)) first <- if (method == "set_props") "object" else ".parent" + args <- member_s7_match(as.list(expr)[-1L], c(first, "...", if (method == "set_props") ".check")) + if (is.null(args)) return(member_value(reason = "s7_argument_matching")) + descriptor <- bindings$.__s7_constructing__ + value <- if (method == "set_props") infer(args$args[[first]]) else member_s7_shape(descriptor, bindings) + if (!isTRUE(value$s7)) return(member_value()) + if (method == "new_object" && !is.null(args$args[[first]])) { + parent <- infer(args$args[[first]]) + if (isTRUE(parent$s7)) { + for (name in intersect(names(parent$slots), names(value$slots))) { + property <- descriptor$properties[[name]] + if (!property$getter && !property$setter) value$slots[name] <- parent$slots[name] + } + } + } + updates <- args$dots + keys <- names(updates) + if (is.null(keys)) keys <- rep("", length(updates)) + if (length(updates) == 1L && !nzchar(keys) && isTRUE(modes$lists)) { + update <- infer(updates[[1L]]) + if (identical(update$type, "list") && (length(update$elements) == 0L || + (!is.null(names(update$elements)) && all(nzchar(names(update$elements)))))) { + updates <- update$elements + } else { + value$slots <- lapply(value$slots, function(slot) member_value(type = slot$type)) + return(value) + } + } else { + if (any(!nzchar(keys))) return(member_value(reason = "unnamed_s7_properties")) + updates <- lapply(updates, infer) + } + if (anyDuplicated(names(updates)) || any(!names(updates) %in% names(value$slot_types))) return(member_value(reason = "unknown_s7_property")) + for (name in names(updates)) { + property <- value$s7_descriptor$properties[[name]] + if (!property$getter && !property$setter) value$slots[name] <- updates[name] + } + return(value) + } + NULL +} + +member_s7_construct <- function(callee, actuals, index, bindings, budget) { + descriptor <- callee$s7_generator + nesting <- budget$s7_construct_depth + if (is.null(nesting)) nesting <- 0L + if (nesting >= 32L) return(member_value(reason = "s7_recursion")) + budget$s7_construct_depth <- nesting + 1L + on.exit(budget$s7_construct_depth <- nesting) + if (isTRUE(descriptor$abstract)) return(member_value(reason = "abstract_s7_class")) + value <- member_s7_shape(descriptor, callee$closure) + matched <- member_s7_match(actuals, names(descriptor$constructor[[2L]])) + if (is.null(matched)) return(member_value(reason = "s7_argument_matching")) + if (isTRUE(descriptor$custom)) { + trail <- budget$s7_constructors + if (descriptor$name %in% trail || length(trail) >= 32L) return(value) + budget$s7_constructors <- c(trail, descriptor$name) + on.exit(budget$s7_constructors <- trail) + scope <- callee$closure + scope$.__s7_constructing__ <- descriptor + scope$.__s7_constructor__ <- member_value(function_expr = descriptor$constructor, closure = scope) + call <- as.call(c(list(as.name(".__s7_constructor__")), + stats::setNames(lapply(seq_along(actuals), function(i) as.name(paste0(".__s7_arg", i))), names(actuals)))) + for (i in seq_along(actuals)) scope[paste0(".__s7_arg", i)] <- list(actuals[[i]]) + result <- member_infer(call, index, scope, budget = budget) + return(if (isTRUE(result$s7) && identical(result$s7_descriptor$name, descriptor$name)) result else value) + } + provided <- names(matched$args) + for (name in intersect(setdiff(names(descriptor$constructor[[2L]]), c(provided, "...")), names(descriptor$properties))) { + property <- descriptor$properties[[name]] + if (is.null(property$default)) next + default <- descriptor$constructor[[2L]][[name]] + if (!identical(default, quote(expr = ))) matched$args[name] <- list( + member_value(binding_expr = default, binding_env = callee$closure)) + } + if (!is.null(descriptor$parent) && !isTRUE(descriptor$parent$abstract) && descriptor$parent$kind == "class") { + parent <- member_s7_generator(descriptor$parent, callee$closure) + parent_args <- if (isTRUE(descriptor$forward)) matched$dots else + matched$args[intersect(names(matched$args), names(descriptor$parent$constructor[[2L]]))] + # Property overrides are forwarded to parents that can accept them. + if (isTRUE(descriptor$forward)) { + overrides <- intersect(names(matched$args), names(descriptor$parent$properties)) + parent_formals <- names(descriptor$parent$constructor[[2L]]) + if (!"..." %in% parent_formals) overrides <- intersect(overrides, parent_formals) + parent_args <- c(matched$args[overrides], parent_args) + } + inherited <- member_s7_construct(parent, parent_args, index, bindings, budget) + if (!isTRUE(inherited$s7)) return(inherited) + for (name in intersect(names(inherited$slots), names(value$slots))) { + property <- descriptor$properties[[name]] + if (!property$getter && !property$setter && + (!isTRUE(descriptor$modes$overrides) || !name %in% names(matched$args))) value$slots[name] <- inherited$slots[name] + } + } + for (name in intersect(names(matched$args), names(value$slots))) { + property <- descriptor$properties[[name]] + if (!property$getter && !property$setter) value$slots[name] <- matched$args[name] + } + value +} + +# Read only known descriptor attributes/list records, never S7 accessors. +member_s7_runtime_descriptor <- function(value, depth = 0L, modes = list(), budget = NULL) { + if (is.null(budget)) { + budget <- new.env(parent = emptyenv()) + budget$remaining <- 4096L + } + budget$remaining <- budget$remaining - 1L + if (depth > 32L || budget$remaining < 0L) return(NULL) + classes <- attr(value, "class", exact = TRUE) + if ("S7_class" %in% classes && typeof(value) == "closure") { + name <- attr(value, "name", exact = TRUE) + properties <- attr(value, "properties", exact = TRUE) + if (!is.character(name) || length(name) != 1L || !is.list(properties) || length(properties) > 256L) return(NULL) + parent <- member_s7_runtime_descriptor(attr(value, "parent", exact = TRUE), depth + 1L, modes, budget) + props <- lapply(properties, function(property) { + if (typeof(property) != "list") return(list(class = NULL, getter = FALSE, setter = FALSE)) + property <- unclass(property) + list(class = member_s7_runtime_descriptor(property$class, depth + 1L, modes, budget), + getter = typeof(property$getter) == "closure", setter = typeof(property$setter) == "closure", + default = if (!is.object(property$default) && !is.function(property$default) && + !is.environment(property$default)) property$default) + }) + return(list(kind = "class", name = name, parent = parent, properties = props, + package = attr(value, "package", exact = TRUE), abstract = isTRUE(attr(value, "abstract", exact = TRUE)), + constructor = member_s7_function(formals(value)), + custom = !"S7_constructor" %in% attr(attr(value, "constructor", exact = TRUE), "class", exact = TRUE), + forward = "..." %in% names(formals(value)), modes = modes[c("class_ref", "overrides")])) + } + if (isS4(value)) { + descriptor <- member_s4_runtime_descriptor(value) + if (!is.null(descriptor)) return(member_s7_s4_descriptor(descriptor)) + } + if (typeof(value) != "list") return(NULL) + value <- unclass(value) + if ("S7_union" %in% classes) { + if (!is.list(value$classes) || length(value$classes) > 256L) return(NULL) + return(list(kind = "union", classes = lapply(value$classes, member_s7_runtime_descriptor, depth + 1L, modes, budget))) + } + if (any(c("S7_base_class", "S7_S3_class") %in% classes)) { + constructor <- value$constructor + if (typeof(constructor) != "closure") return(NULL) + formals <- as.list(formals(constructor)) + default <- value$default + if (is.null(default) && identical(body(constructor), quote(.data)) && identical(names(formals), ".data")) default <- formals[[1L]] + # A closure-valued default cannot be serialized as executable code. + if (is.null(default)) default <- as.name(".__unknown_s7_default__") + if (is.object(default) || is.function(default) || is.environment(default)) default <- as.name(".__unknown_s7_default__") + return(list(kind = "base", name = value$class, constructor = member_s7_function(formals), + custom = !"S7_constructor" %in% attr(constructor, "class", exact = TRUE), + s3 = "S7_S3_class" %in% classes, default = default)) + } + if ("S7_external_class" %in% classes && is.character(value$package) && length(value$package) == 1L && + is.character(value$name) && length(value$name) == 1L) { + return(list(kind = "external", name = value$name, package = value$package, + version = if (is.character(value$version)) value$version)) + } + if ("S7_any" %in% classes) return(list(kind = "any")) + NULL +} + +member_slot <- function(value, name, index, bindings, budget = NULL) { + if (!isTRUE(value$s7)) return(member_s4_slot(value, name, index, bindings, budget)) + property <- member_lookup(value$slots, name) + if (is.null(property)) return(member_value(reason = "unknown_s7_property")) + spec <- property$s7_descriptor + if (identical(spec$kind, "external")) { + scope <- bindings + scope$.__s7_package__ <- value$s7_descriptor$package + descriptor <- member_s7_external(spec, index, scope, budget) + if (!is.null(descriptor)) return(member_s7_shape(descriptor, bindings)) + return(member_value(type = spec$name, reason = "unresolved_s7_external")) + } + alias <- value$s7_descriptor$properties[[name]]$alias + if (is.character(alias) && length(alias) == 1L && !identical(alias, name)) { + property <- member_lookup(value$slots, alias) + if (is.null(property)) return(member_value()) + } + if (is.null(property$binding_expr)) return(property) + if (is.null(budget)) { + budget <- new.env(parent = emptyenv()) + budget$remaining <- 20000L + } + trail <- budget$s7_slots + key <- paste(value$s7_descriptor$name, name, sep = "::") + if (key %in% trail || length(trail) >= 32L) return(property) + budget$s7_slots <- c(trail, key) + on.exit(budget$s7_slots <- trail) + result <- member_infer(property$binding_expr, index, property$binding_env, budget = budget) + if (length(result$type) || !is.null(result$function_expr)) result else property +} + +# Normalize S4 class representations without initialize() or prototype access. +member_s7_s4_descriptor <- function(descriptor) { + if (is.null(descriptor) || identical(descriptor$complete, FALSE)) return(NULL) + properties <- lapply(descriptor$slots, function(type) { + list(class = list(kind = "base", name = as.character(type)), getter = FALSE, setter = FALSE) + }) + list(kind = "s4", name = descriptor$name, package = descriptor$package, slots = descriptor$slots, + properties = properties, abstract = descriptor$virtual) +} + +member_s7_spec <- function(value, index, bindings, budget, resolve = TRUE) { + descriptor <- value$s7_descriptor + if (identical(descriptor$kind, "external")) { + if (!resolve) return(descriptor) + resolved <- member_s7_external(descriptor, index, bindings, budget) + if (!is.null(resolved)) { + resolved$external <- TRUE + resolved$package <- descriptor$package + resolved$name <- descriptor$name + return(resolved) + } + return(descriptor) + } + if (!is.null(descriptor)) return(descriptor) + if (identical(value$type, "NULL")) return(list(kind = "base", name = "NULL", default = NULL)) + class <- value$s4_generator + if (!is.null(class)) { + scope <- bindings + if (!is.null(class$recipe)) scope$.__s4_classes__[class$name] <- list(class$recipe) + shape <- member_s4_shape(class$name, index, scope, class$package, budget = budget) + descriptor <- member_s7_s4_descriptor(list(name = class$name, package = class$package, + slots = shape$slot_types, virtual = FALSE, complete = !is.null(shape$slot_types))) + for (name in names(descriptor$properties)) { + type <- descriptor$properties[[name]]$class$name + root <- member_lookup(index$namespace_roots, paste0("S7::class_", type)) + if (!is.null(root$s7_descriptor)) descriptor$properties[[name]]$class <- root$s7_descriptor + } + return(descriptor) + } + NULL +} + +member_s7_external <- function(descriptor, index, bindings, budget) { + if (is.null(budget)) budget <- new.env(parent = emptyenv()) + key <- paste(descriptor$package, descriptor$name, sep = "::") + trail <- budget$s7_external + if (key %in% trail || length(trail) >= 32L) return(NULL) + budget$s7_external <- c(trail, key) + on.exit(budget$s7_external <- trail) + local <- identical(descriptor$package, index$package) + same <- local || identical(descriptor$package, bindings$.__s7_package__) + target <- if (local) index else member_lookup(index$namespace_indices, descriptor$package) + if (is.null(target)) target <- member_lookup(index$s7_dependencies, descriptor$package) + if (is.null(target) && same && !is.null(index$document_bindings)) target <- index + if (is.null(target) || (!same && !descriptor$name %in% target$exports)) return(NULL) + if (!is.null(descriptor$version)) { + installed <- target$identity$version + ok <- tryCatch(!is.null(installed) && utils::compareVersion(installed, descriptor$version) >= 0L, + error = function(e) FALSE) + if (!ok) return(NULL) + } + value <- member_lookup(target$package_roots, descriptor$name) + if (is.null(value) && same) value <- member_infer(as.name(descriptor$name), target, bindings, budget = budget) + if (identical(value$s7_descriptor$kind, "external")) return(member_s7_external(value$s7_descriptor, target, bindings, budget)) + if (identical(value$s7_descriptor$kind, "class")) value$s7_descriptor else NULL +} + +# Decode current and legacy instance storage. Class references are read only +# through inert bindings; an active binding or promise is never forced. +member_s7_instance_descriptor <- function(value, modes = list()) { + if (!"S7_object" %in% attr(value, "class", exact = TRUE)) return(NULL) + class <- attr(value, "_S7_class", exact = TRUE) + if (is.null(class)) class <- attr(value, "S7_class", exact = TRUE) + if (is.environment(class)) { + if (!"S7_class_ref" %in% attr(class, "class", exact = TRUE)) return(NULL) + record <- member_binding(class, "class") + if (!identical(record[[1L]], "value")) return(NULL) + class <- record[[2L]] + } + descriptor <- member_s7_runtime_descriptor(class, modes = modes) + if (identical(descriptor$kind, "class")) descriptor else NULL +} + +# Capture already-loaded external class dependencies in the worker. Requests +# resolve these records without loading a package or calling an accessor. +member_s7_dependencies <- function(roots, package, modes) { + dependencies <- list() + queue <- lapply(roots, function(value) value$s7_descriptor) + seen <- character() + budget <- new.env(parent = emptyenv()) + budget$remaining <- 4096L + references <- function(descriptor, depth = 0L) { + budget$remaining <- budget$remaining - 1L + if (is.null(descriptor) || depth > 32L || budget$remaining < 0L) return(list()) + if (identical(descriptor$kind, "external")) return(list(descriptor)) + out <- references(descriptor$parent, depth + 1L) + for (class in c(descriptor$classes, lapply(descriptor$properties, function(property) property$class))) { + out <- c(out, references(class, depth + 1L)) + } + out + } + for (pass in seq_len(16L)) { + refs <- unlist(lapply(queue, references), recursive = FALSE) + next_queue <- list() + for (ref in refs) { + key <- paste(ref$package, ref$name, sep = "::") + if (key %in% seen || length(seen) >= 256L || !ref$package %in% loadedNamespaces()) next + seen <- c(seen, key) + ns <- asNamespace(ref$package) + exports <- getNamespaceExports(ns) + if (!identical(package, ref$package) && !ref$name %in% exports) next + record <- member_binding(ns, ref$name, materialize = TRUE) + if (!identical(record[[1L]], "value")) next + descriptor <- member_s7_runtime_descriptor(record[[2L]], modes = modes) + if (!identical(descriptor$kind, "class")) next + if (is.null(dependencies[[ref$package]])) { + dependencies[[ref$package]] <- list(package = ref$package, exports = exports, + identity = list(version = as.character(getNamespaceVersion(ns))), package_roots = list()) + } + dependencies[[ref$package]]$package_roots[ref$name] <- list(member_s7_generator(descriptor)) + next_queue[[length(next_queue) + 1L]] <- descriptor + } + if (!length(next_queue)) break + queue <- next_queue + } + dependencies +} diff --git a/R/settings.R b/R/settings.R index adb1f1bf..ca316bd3 100644 --- a/R/settings.R +++ b/R/settings.R @@ -8,6 +8,7 @@ Settings <- R6::R6Class("Settings", rich_documentation = TRUE, snippet_support = TRUE, max_completions = 200, + member_completion = TRUE, lint_cache = FALSE, diagnostics_cache_ttl = 5, parse_delay = 0.15, diff --git a/R/signature.R b/R/signature.R index ea5f0072..1053bd70 100644 --- a/R/signature.R +++ b/R/signature.R @@ -82,6 +82,33 @@ signature_reply <- function(id, uri, workspace, document, point) { } result <- document$detect_call(point) + if (isTRUE(lsp_settings$get("member_completion"))) { + location <- member_call_location(document, point, result, symbols = TRUE) + if (!is.null(location)) { + symbol <- member_symbol(uri, workspace, document, location) + if (is.null(location$cursor$accessor) && is.null(symbol$value$s7_generator)) location <- NULL + } + if (!is.null(location)) { + sig <- symbol$signature + if (is.null(sig)) { + return(Response$new(id, list(signatures = list()))) + } + doc <- member_symbol_documentation(workspace, symbol, uri) + description <- if (is.character(doc)) doc else if (is.list(doc)) doc$description + return(Response$new(id, result = list( + signatures = list(list( + label = sig, + documentation = list(kind = "markdown", value = if (is.null(description)) "" else description), + parameters = parse_signature_parameters(sig) + )), + activeSignature = 0L, + activeParameter = detect_active_parameter( + document$content, + result$opening$row, result$opening$col, point$row, point$col, sig + ) + ))) + } + } SignatureInformation <- list() activeSignature <- NULL diff --git a/R/task.R b/R/task.R index 506c6ec7..b9d56619 100644 --- a/R/task.R +++ b/R/task.R @@ -5,6 +5,7 @@ Task <- R6::R6Class("Task", session = NULL, target = NULL, args = NULL, + profiles = TRUE, callback = NULL, error = NULL, cancelled = FALSE, @@ -25,9 +26,11 @@ Task <- R6::R6Class("Task", public = list( time = NULL, delay = NULL, - initialize = function(target, args, callback = NULL, error = NULL, delay = 0) { + initialize = function(target, args, callback = NULL, error = NULL, delay = 0, + profiles = TRUE) { private$target <- target private$args <- args + private$profiles <- profiles private$callback <- callback private$error <- error self$time <- Sys.time() @@ -42,7 +45,7 @@ Task <- R6::R6Class("Task", private$process <- callr::r_bg( private$target, private$args, - system_profile = TRUE, user_profile = TRUE + system_profile = private$profiles, user_profile = private$profiles ) } else { private$session <- session @@ -552,12 +555,14 @@ package_call <- function(target) { ), envir = baseenv()) } -create_task <- function(target, args, callback = NULL, error = NULL, delay = 0) { +create_task <- function(target, args, callback = NULL, error = NULL, delay = 0, + profiles = TRUE) { Task$new( target = target, args = args, callback = callback, error = error, - delay = delay + delay = delay, + profiles = profiles ) } diff --git a/R/workspace.R b/R/workspace.R index b3b6cdf2..fb514b10 100644 --- a/R/workspace.R +++ b/R/workspace.R @@ -236,6 +236,7 @@ Workspace <- R6::R6Class("Workspace", diagnostics_cache = NULL, # Performance: Cache diagnostics by content hash diagnostics_globals_cache = NULL, type_hierarchy_cache = NULL, + member_metadata = NULL, initialize = function(root) { self$root <- root @@ -270,6 +271,7 @@ Workspace <- R6::R6Class("Workspace", self$diagnostics_globals_cache <- NULL private$import_globals_cache <- collections::dict() self$type_hierarchy_cache <- collections::dict() + self$member_metadata <- ByteLruCache$new(32 * 1024^2, max_entries = 16L) }, load_package = function(pkgname) { diff --git a/README.md b/README.md index 2b364e7c..c22fee1e 100644 --- a/README.md +++ b/README.md @@ -185,6 +185,7 @@ settings | default | description `r.lsp.rich_documentation` | `true` | rich documentation with enhanced markdown features `r.lsp.snippet_support` | `true` | enable snippets in auto completion `r.lsp.max_completions` | 200 | maximum number of completion items +`r.lsp.member_completion` | `true` | infer `$` members and S4 `@` slots for completion, signature help and hover from document syntax and cached package metadata without executing document code `r.lsp.lint_cache` | `false` | toggle caching of lint results `r.lsp.parse_delay` | `0.15` | seconds to debounce parsing after an edit `r.lsp.diagnostics_delay` | `0.75` | seconds to debounce diagnostics after the current parse diff --git a/src/completion.c b/src/completion.c index 5241066c..b2d30376 100644 --- a/src/completion.c +++ b/src/completion.c @@ -2,6 +2,69 @@ #include #include +#include + +/* Inspect binding kind before looking up a value. In particular, findVarInFrame + * must never reach an active binding. Unforced promises are returned as missing + * unless a package metadata worker explicitly requests materialization. */ +SEXP member_binding_c(SEXP env, SEXP name, SEXP materialize) { + if (TYPEOF(env) != ENVSXP || TYPEOF(name) != STRSXP || XLENGTH(name) != 1 || + STRING_ELT(name, 0) == NA_STRING) Rf_error("Invalid binding"); + SEXP sym = Rf_installChar(STRING_ELT(name, 0)); + SEXP result = PROTECT(Rf_allocVector(VECSXP, 2)); +#if R_VERSION >= R_Version(4, 6, 0) + R_BindingType_t kind = R_GetBindingType(sym, env); + if (kind == R_BindingTypeActive) { + SET_VECTOR_ELT(result, 0, Rf_mkString("active")); + SET_VECTOR_ELT(result, 1, R_ActiveBindingFunction(sym, env)); + } else if (kind == R_BindingTypeValue || kind == R_BindingTypeForced || + (kind == R_BindingTypeDelayed && Rf_asLogical(materialize) == TRUE)) { + SEXP value = PROTECT(R_getVar(sym, env, FALSE)); + SET_VECTOR_ELT(result, 0, Rf_mkString("value")); + SET_VECTOR_ELT(result, 1, value); + UNPROTECT(1); + } else { + SET_VECTOR_ELT(result, 0, Rf_mkString("deferred")); + } +#else + /* Older R binding-kind APIs require an existing name. Enumerating names + * does not force promises or invoke active bindings. */ + SEXP binding_names = PROTECT(R_lsInternal3(env, TRUE, FALSE)); + int present = 0; + for (R_xlen_t i = 0; i < XLENGTH(binding_names); ++i) { + if (strcmp(CHAR(STRING_ELT(binding_names, i)), CHAR(STRING_ELT(name, 0))) == 0) { + present = 1; + break; + } + } + UNPROTECT(1); + if (!present) { + SET_VECTOR_ELT(result, 0, Rf_mkString("deferred")); + } else if (R_BindingIsActive(sym, env)) { + SET_VECTOR_ELT(result, 0, Rf_mkString("active")); +#if R_VERSION >= R_Version(4, 0, 0) + SET_VECTOR_ELT(result, 1, R_ActiveBindingFunction(sym, env)); +#endif + } else { + SEXP value = Rf_findVarInFrame(env, sym); + if (TYPEOF(value) == PROMSXP && PRVALUE(value) != R_UnboundValue) { + value = PRVALUE(value); + } else if (TYPEOF(value) == PROMSXP && Rf_asLogical(materialize) == TRUE) { + /* This branch is only used on the selected package namespace in + * a background worker, never on document or getter bindings. */ + value = Rf_eval(sym, env); + } + if (value == R_UnboundValue || TYPEOF(value) == PROMSXP) { + SET_VECTOR_ELT(result, 0, Rf_mkString("deferred")); + } else { + SET_VECTOR_ELT(result, 0, Rf_mkString("value")); + SET_VECTOR_ELT(result, 1, value); + } + } +#endif + UNPROTECT(1); + return result; +} typedef enum { TOKEN_OTHER = 0, diff --git a/src/completion.h b/src/completion.h index 077a5651..24d730ac 100644 --- a/src/completion.h +++ b/src/completion.h @@ -4,6 +4,8 @@ #include #include +SEXP member_binding_c(SEXP env, SEXP name, SEXP materialize); + /* Extract row indexes needed to build document completion indexes. */ SEXP completion_parse_index_c( SEXP id, diff --git a/src/languageserver.c b/src/languageserver.c index da42d3da..291bb8a8 100644 --- a/src/languageserver.c +++ b/src/languageserver.c @@ -48,6 +48,7 @@ static const R_CallMethodDef CallEntries[] = { {"fuzzy_find_c", (DL_FUNC) &fuzzy_find_c, 2}, {"completion_parse_index_c", (DL_FUNC) &completion_parse_index_c, 7}, {"completion_select_c", (DL_FUNC) &completion_select_c, 4}, + {"member_binding_c", (DL_FUNC) &member_binding_c, 3}, {"source_calls_c", (DL_FUNC) &source_calls_c, 1}, {"navigation_find_token_c", (DL_FUNC) &navigation_find_token_c, 6}, {"reference_resolve_local_c", (DL_FUNC) &reference_resolve_local_c, 8}, diff --git a/tests/testthat/helper-utils.R b/tests/testthat/helper-utils.R index 7ecaf371..356ac17c 100644 --- a/tests/testthat/helper-utils.R +++ b/tests/testthat/helper-utils.R @@ -501,6 +501,11 @@ respond_semantic_tokens_range <- function(client, path, start_pos, end_pos, ..., } wait_for <- function(client, method, timeout = 30) { + if (missing(timeout) && identical(Sys.getenv("R_COVR"), "true")) { + # Diagnostics now wait for parsing. Coverage adds overhead to both + # workers, especially when several test processes start them together. + timeout <- 60 + } storage <- new.env(parent = .GlobalEnv) start_time <- Sys.time() remaining <- timeout diff --git a/tests/testthat/test-completion.R b/tests/testthat/test-completion.R index 2270c58c..0db2af21 100644 --- a/tests/testthat/test-completion.R +++ b/tests/testthat/test-completion.R @@ -1709,3 +1709,78 @@ test_that("Token completion supports indexed and XML parse data", { list() ) }) + +test_that("Static chained members are delivered over LSP without evaluating arguments", { + skip_on_cran() + client <- language_client() + temp_file <- withr::local_tempfile(fileext=".R") + text <- paste0("factory <- function(x) list(step=function() list(finish=x))\n", + "factory(stop(\"do not execute\"))$step()$") + client %>% did_open(temp_file,text=text) + result <- client %>% respond_completion(temp_file,c(1L,nchar(strsplit(text,"\n",fixed=TRUE)[[1L]][[2L]]))) + expect_true("finish" %in% vapply(result$items,`[[`,character(1L),"label")) + member <- result$items[[which(vapply(result$items,`[[`,character(1L),"label") == "finish")]] + expect_identical(member$data$type,"member") +}) + +test_that("Installed Polars metadata is prepared before chained LSP completion", { + skip_on_cran() + skip_if_not_installed("polars") + client <- language_client() + temp_file <- withr::local_tempfile(fileext=".R") + lines <- c("library(polars)", "q <- pl$scan_csv(csv_file)$filter(predicate)", "q$collect") + client %>% did_open(temp_file,text=paste(lines,collapse="\n")) + # Resolution is asynchronous; requests never initialize the package. + deadline <- Sys.time() + 15 + repeat { + result <- client %>% respond_completion(temp_file,c(2L,2L)) + labels <- vapply(result$items,`[[`,character(1L),"label") + if ("collect" %in% labels && any(vapply(result$items,function(x) identical(x$data$type,"member"),logical(1L)))) break + if (Sys.time() > deadline) break + Sys.sleep(0.1) + } + expect_true("group_by" %in% labels) + expect_true(any(vapply(result$items,function(x) identical(x$data$type,"member"),logical(1L)))) +}) + +test_that("The first dollar trigger after an edit uses current Polars members", { + skip_on_cran() + skip_if_not_installed("polars") + client <- language_client() + temp_file <- withr::local_tempfile(fileext = ".R") + uri <- path_to_uri(temp_file) + lines <- c( + "library(polars)", "", + "csv_file <- tempfile(fileext = \".csv\")", + "write.csv(iris, csv_file, row.names = FALSE)", "", + "q <- pl$scan_csv(csv_file, infer_schema_files = 10)", + "q$group_by(\"Species\")" + ) + client %>% did_open(temp_file, text = paste(lines, collapse = "\n")) + # Warm only package metadata; the tested completion follows didChange with + # no sleep, request retry, or second dollar trigger. A long debounce makes + # the request arrive before the updated document has been parsed. + deadline <- Sys.time() + 15 + repeat { + ready <- respond_completion(client, temp_file, c(6L, 2L), retry = FALSE) + if (any(vapply(ready$items, function(item) identical(item$data$type, "member"), logical(1L)))) break + if (Sys.time() > deadline) break + Sys.sleep(0.1) + } + expect_true(any(vapply(ready$items, function(item) identical(item$data$type, "member"), logical(1L)))) + notify(client, "workspace/didChangeConfiguration", list(settings = list(parse_delay = 0.5))) + end <- list(line = 6L, character = nchar(lines[[7L]])) + notify(client, "textDocument/didChange", list( + textDocument = list(uri = uri, version = 2L), + contentChanges = list(list(range = list(start = end, end = end), text = "$")) + )) + result <- respond(client, "textDocument/completion", list( + textDocument = list(uri = uri), + position = list(line = 6L, character = end$character + 1L), + context = list(triggerKind = 2L, triggerCharacter = "$") + ), retry = FALSE) + labels <- vapply(result$items, `[[`, character(1L), "label") + expect_true("agg" %in% labels) + expect_false(any(c("fileext", "infer_schema_files", "row.names") %in% labels)) + expect_true(all(vapply(result$items, function(item) identical(item$data$type, "member"), logical(1L)))) +}) diff --git a/tests/testthat/test-formatting-background.R b/tests/testthat/test-formatting-background.R index 777c5237..da202d01 100644 --- a/tests/testthat/test-formatting-background.R +++ b/tests/testthat/test-formatting-background.R @@ -31,6 +31,24 @@ formatting_test_task <- function(fixture, id) { fixture$manager$.__enclos_env__$private$pending_tasks$get(as.character(id)) } +formatting_wait_for_tasks <- function(fixture, timeout = 15) { + if (missing(timeout) && identical(Sys.getenv("R_COVR"), "true")) { + # Starting a worker and loading the instrumented namespace takes longer + # under coverage, especially alongside other parallel test processes. + timeout <- 60 + } + deadline <- Sys.time() + timeout + while (fixture$manager$has_work() && Sys.time() < deadline) { + fixture$manager$run_tasks() + fixture$manager$check_tasks() + Sys.sleep(0.01) + } + if (fixture$manager$has_work()) { + stop("Background formatting did not complete within ", timeout, " seconds") + } + invisible(NULL) +} + test_that("explicit formatting handlers enqueue immutable snapshots", { fixture <- formatting_fixture(c("x=1", "y=2")) fixture$params$range <- list(start = position(0L, 0L), end = position(0L, 3L)) @@ -144,12 +162,7 @@ test_that("background formatting preserves custom styles and literate boundaries c("Prose", "```{r}", "x=1", "```", "```{python}", "x=1", "```"), "file:///formatting.qmd") text_document_formatting(fixture$self, 1L, fixture$params) - deadline <- Sys.time() + 15 - while (fixture$manager$has_work() && Sys.time() < deadline) { - fixture$manager$run_tasks() - fixture$manager$check_tasks() - Sys.sleep(0.01) - } + formatting_wait_for_tasks(fixture) expect_length(fixture$self$deliveries, 1L) reply <- fixture$self$deliveries[[1L]] expect_null(reply$error) @@ -161,12 +174,7 @@ test_that("background formatting preserves custom styles and literate boundaries # Reusing the same session must pick up a changed server-side option. options(languageserver.formatting_style = NULL) text_document_formatting(fixture$self, 2L, fixture$params) - deadline <- Sys.time() + 15 - while (fixture$manager$has_work() && Sys.time() < deadline) { - fixture$manager$run_tasks() - fixture$manager$check_tasks() - Sys.sleep(0.01) - } + formatting_wait_for_tasks(fixture) expect_length(fixture$self$deliveries, 2L) expect_equal(fixture$self$deliveries[[2L]]$result[[1L]]$newText, "x <- 1") @@ -174,12 +182,7 @@ test_that("background formatting preserves custom styles and literate boundaries fixture$params$ranges <- list(fixture$params$range, fixture$params$range) text_document_range_formatting(fixture$self, 3L, fixture$params) text_document_ranges_formatting(fixture$self, 4L, fixture$params) - deadline <- Sys.time() + 15 - while (fixture$manager$has_work() && Sys.time() < deadline) { - fixture$manager$run_tasks() - fixture$manager$check_tasks() - Sys.sleep(0.01) - } + formatting_wait_for_tasks(fixture) expect_length(fixture$self$deliveries, 4L) for (id in 3:4) { reply <- fixture$self$deliveries[[id]] diff --git a/tests/testthat/test-handlers-langfeatures.R b/tests/testthat/test-handlers-langfeatures.R index 15e76760..726ee7cd 100644 --- a/tests/testthat/test-handlers-langfeatures.R +++ b/tests/testthat/test-handlers-langfeatures.R @@ -15,6 +15,9 @@ langfeature_handler_fixture <- function(content = "value <- 1") { )) self$pending_replies <- collections::dict() self$pending_replies$set(fixture$uri, list( + `textDocument/completion` = collections::queue(), + `textDocument/hover` = collections::queue(), + `textDocument/signatureHelp` = collections::queue(), `textDocument/documentSymbol` = collections::queue(), `textDocument/codeLens` = collections::queue(), `textDocument/documentLink` = collections::queue(), @@ -256,3 +259,99 @@ test_that("exit, cancellation, and trace notifications update server state", { protocol_set_trace(self, list(value = "verbose")) expect_true(lsp_settings$get("trace")) }) + +test_that("Dollar completion waits for the current parse and replies once", { + fixture <- langfeature_handler_fixture(c( + "fileext <- \".csv\"", + "q <- list(group_by=function(...) list(agg=function(...) NULL,head=function() NULL))", + "q$group_by(\"Species\")" + )) + document <- fixture$document + self <- fixture$self + workspace <- fixture$workspace + queue <- collections::queue() + queues <- self$pending_replies$get(fixture$uri) + queues[["textDocument/completion"]] <- queue + self$pending_replies$set(fixture$uri, queues) + self$request_handlers <- list(`textDocument/completion` = text_document_completion) + workspace$update_parse_data <- function(uri, data) document$update_parse_data(data) + workspace$parse_cache <- list(set = function(...) NULL) + workspace$update_loaded_packages <- function() NULL + document$requested_packages <- character() + document$set_content(2L, c( + document$content[-length(document$content)], + "q$group_by(\"Species\")$" + )) + params <- list( + textDocument = list(uri = fixture$uri), + position = list(line = 2L, character = nchar(document$content[[3L]])), + context = list(triggerKind = 2L, triggerCharacter = "$") + ) + + text_document_completion(self, 101L, params) + expect_length(self$deliveries, 0L) + expect_identical(queue$size(), 1L) + + current <- parse_document(fixture$uri, document$content) + expect_true(current$parse_error) + parse_callback(self, fixture$uri, 2L, current) + expect_length(self$deliveries, 1L) + expect_identical(self$deliveries[[1L]]$id, 101L) + labels <- vapply(self$deliveries[[1L]]$result$items, `[[`, character(1L), "label") + expect_setequal(labels, c("agg", "head")) + expect_identical(queue$size(), 0L) +}) + +test_that("Nonmember completion remains immediate while parsing an edit", { + fixture <- langfeature_handler_fixture("value <- 1") + fixture$document$set_content(2L, "val") + stub(text_document_completion, "completion_reply", function(id, ...) { + Response$new(id = id, result = list(items = list())) + }) + text_document_completion(fixture$self, 102L, list( + textDocument = list(uri = fixture$uri), + position = list(line = 0L, character = 3L) + )) + expect_length(fixture$self$deliveries, 1L) + expect_identical(fixture$self$deliveries[[1L]]$id, 102L) +}) + +test_that("Member signature and hover wait for current syntax and cancel superseded requests", { + fixture <- langfeature_handler_fixture(c( + "q <- list(run=function(old=1) NULL)", "q$run(old=1)" + )) + document <- fixture$document + self <- fixture$self + workspace <- fixture$workspace + self$request_handlers <- list( + `textDocument/hover` = text_document_hover, + `textDocument/signatureHelp` = text_document_signature_help + ) + workspace$update_parse_data <- function(uri, data) document$update_parse_data(data) + workspace$parse_cache <- list(set = function(...) NULL) + document$set_content(2L, c("q <- list(run=function(current, flag=TRUE) NULL)", "q$run(flag = ")) + params <- list( + textDocument = list(uri = fixture$uri), + position = list(line = 1L, character = nchar(document$content[[2L]])) + ) + text_document_signature_help(self, 201L, params) + text_document_signature_help(self, 202L, params) + params$position$character <- 4L + text_document_hover(self, 203L, params) + expect_length(self$deliveries, 1L) + expect_identical(self$deliveries[[1L]]$id, 201L) + expect_identical(self$deliveries[[1L]]$error$code, ErrorCodes$RequestCancelled) + queues <- self$pending_replies$get(fixture$uri) + expect_identical(queues[["textDocument/hover"]]$size(), 1L) + expect_identical(queues[["textDocument/signatureHelp"]]$size(), 1L) + parse_callback(self, fixture$uri, 2L, parse_document(fixture$uri, document$content)) + expect_length(self$deliveries, 3L) + replies <- self$deliveries[-1L] + sig <- replies[[which(vapply(replies, function(x) x$id == 202L, logical(1L)))]]$result + hover <- replies[[which(vapply(replies, function(x) x$id == 203L, logical(1L)))]]$result + expect_identical(sig$signatures[[1L]]$label, "run(current, flag = TRUE)") + expect_identical(sig$activeParameter, 1L) + expect_identical(hover$contents, "```r\nrun(current, flag = TRUE)\n```") + expect_identical(queues[["textDocument/hover"]]$size(), 0L) + expect_identical(queues[["textDocument/signatureHelp"]]$size(), 0L) +}) diff --git a/tests/testthat/test-member-completion.R b/tests/testthat/test-member-completion.R new file mode 100644 index 00000000..4aa026d5 --- /dev/null +++ b/tests/testthat/test-member-completion.R @@ -0,0 +1,394 @@ +member_fixture <- function(code, snapshots = list(), point = NULL, language = "r") { + content <- strsplit(code, "\n", fixed = TRUE)[[1L]] + uri <- if (language == "r") "file:///members.R" else "file:///members.qmd" + document <- Document$new(uri, language = language, version = 1L, content = content) + document$parse_data <- parse_document(uri, content, is_rmarkdown = document$is_rmarkdown) + metadata <- collections::dict() + for (package in names(snapshots)) metadata$set(package, member_index_thaw(snapshots[[package]])) + workspace <- list(member_metadata = metadata) + if (is.null(point)) point <- list(row = length(content) - 1L, col = nchar(tail(content, 1L))) + list(document = document, workspace = workspace, point = point) +} + +member_items <- function(code, snapshots = list(), point = NULL, language = "r", limit = 200L) { + fixture <- member_fixture(code, snapshots, point, language) + member_completion( + fixture$document$uri, fixture$workspace, fixture$document, + fixture$point, TRUE, limit + ) +} + +member_labels <- function(...) vapply(member_items(...), `[[`, character(1L), "label") + +test_that("Static inference stops at node, depth and time limits", { + index <- member_generic_index("") + budget <- new.env(parent = emptyenv()) + budget$remaining <- 0L + budget$exhausted <- FALSE + expect_identical(member_infer(quote(list(alpha = 1)), index, budget = budget)$reason, "budget") + expect_true(budget$exhausted) + + budget$remaining <- 20000L + budget$exhausted <- FALSE + expect_identical(member_infer(quote(list(alpha = 1)), index, depth = 65L, budget = budget)$reason, "budget") + expect_true(budget$exhausted) + + budget$exhausted <- FALSE + budget$deadline <- proc.time()[[3L]] - 1 + expect_identical(member_infer(quote(list(alpha = 1)), index, budget = budget)$reason, "budget") + expect_true(budget$exhausted) +}) + +test_that("Static members propagate through source factories and aliases", { + expect_identical(member_labels("x <- list(alpha=1,beta=2)\ny <- x\ny$"), c("alpha", "beta")) + expect_identical(member_labels(paste0( + "factory <- function(x) list(step=function() list(finish=x))\n", + "factory({stop(\"argument\")})$step()$" + )), "finish") + expect_identical(member_labels(paste0( + "factory <- function(x) {self <- new.env(); self$filter <- function(p) self;", + " self$collect <- function() list(value=x); self}\n", + "factory(unresolved)$filter(pred)$" + )), c("collect", "filter")) + expect_identical(member_labels("x <- list(a=1)\nx <- list(b=1)\nx$"), "b") + expect_identical(member_labels("x <- list(a=1)\ny <- x\nx <- list(b=1)\ny$"), "a") + expect_identical(member_labels("f <- function(x) x\nf(list(a=1))$"), "a") + expect_identical(member_labels("f <- function(flag) {if(flag) return(list(a=1,b=1)); list(a=2,c=1)}\nf(unknown)$"), "a") + expect_length(member_labels("f <- function(flag) {if(flag) return(opaque()); list(a=1)}\nf(unknown)$"), 0L) + expect_length(member_labels("f <- function(x) {out <- list(a=1); for (out in x) NULL; out}\nf(unknown)$"), 0L) + expect_length(member_labels("f <- function() f()\nf()$"), 0L) +}) + +test_that("Cursor recovery respects quoting, comments, Unicode, and replacement ranges", { + expect_identical(member_labels("bad <- )\nx <- list(alpha=1)\nx$al"), "alpha") + expect_identical(member_labels("x <- list(alpha=1)\nx $ al"), "alpha") + expect_identical(member_labels("list(\n alpha=list(beta=1)\n)$alpha$"), "beta") + expect_length(member_labels("# x$"), 0L) + expect_length(member_labels("\"list(a=1)$\""), 0L) + code <- "x <- list(`a b`=1, beta=2)\nx$`a" + item <- member_items(code)[[1L]] + expect_identical(item$label, "a b") + expect_identical(item$textEdit$newText, "`a b`") + expect_identical(item$textEdit$range$start$character, 2L) + code <- "x <- list(alpha=1)\n\"\U0001f680\"; x$alXYZ" + item <- member_items(code, point = list(row = 1L, col = 9L))[[1L]] + expect_identical(item$textEdit$range$start$character, 8L) + expect_identical(item$textEdit$range$end$character, 13L) + expect_identical(member_labels("```{r}\nx <- list(alpha=1)\nx$\n```", + point = list(row = 2L, col = 2L), language = "quarto" + ), "alpha") + expect_length(member_labels("x$\n```{python}\nx$\n```", + point = list(row = 2L, col = 2L), language = "quarto" + ), 0L) + items <- member_items("list(a=1,b=1,c=1)$", limit = 2L) + expect_length(items, 2L) + expect_true(isTRUE(attr(items, "truncated"))) +}) + +test_that("Lexical shadowing and source position prevent invented members", { + expect_length(member_labels("list <- function(...) unknown()\nlist(a=1)$"), 0L) + expect_length(member_labels("new.env <- function(...) unknown()\nnew.env()$"), 0L) + expect_length(member_labels("x$\nx <- list(a=1)", point = list(row = 0L, col = 2L)), 0L) + expect_length(member_labels("x <- list(a=1)\nf <- function(x) { x$\n}", point = list(row = 1L, col = 22L)), 0L) + expect_identical(member_labels("f <- function() {x <- list(a=1); x$\n}", point = list(row = 0L, col = 44L)), "a") + expect_length(member_labels("x <- list(a=1)\nx$a <- opaque()\nx$"), 0L) +}) + +test_that("R6 fluent APIs expose public inheritance without initialization", { + code <- paste0( + "Parent <- R6::R6Class(\"Parent\", public=list(base=function() self, ", + "field=1))\nChild <- R6::R6Class(\"Child\", inherit=Parent, ", + "public=list(initialize=function() stop(\"must not initialize\"),", + "base=function() list(done=1), child=function() self),", + "private=list(secret=1), active=list(danger=function() stop(\"getter\")))\n" + ) + expect_identical( + member_labels(paste0(code, "Child$new()$child()$")), + c("base", "child", "danger", "field", "initialize") + ) + expect_identical(member_labels(paste0(code, "Child$new()$base()$")), "done") + expect_length(member_labels(paste0(code, "Child$new()$danger$")), 0L) +}) + +test_that("Runtime metadata skips deferred values and active getters", { + marker <- tempfile() + on.exit(unlink(marker)) + env <- new.env(parent = emptyenv()) + env$factory <- function(x) list(step = function() list(finish = x)) + makeActiveBinding("unsafe", function() { + writeLines("getter", marker) + stop("getter") + }, env) + delayedAssign("deferred", + { + writeLines("promise", marker) + stop("promise") + }, + assign.env = env + ) + snapshot <- member_snapshot(env) + shape <- member_snapshot_shape(snapshot) + expect_identical(sort(names(shape$fields)), c("deferred", "factory", "unsafe")) + expect_null(shape$fields$deferred$type) + expect_null(shape$fields$unsafe$type) + expect_false(file.exists(marker)) + expect_identical(member_binding(env, "deferred")[[1L]], "deferred") +}) + +test_that("Installed Polars metadata resolves all original query positions without execution", { + skip_if_not_installed("polars") + snapshot <- member_prepare_package("polars") + query <- paste0( + "q <- pl$scan_csv(csv_file, infer_schema_files=10)$filter(", + "pl$col(\"Sepal.Length\") > 5)$group_by(\"Species\", .maintain_order=TRUE)", + "$agg(pl$all()$sum())" + ) + positions <- gregexpr("$", query, fixed = TRUE)[[1L]] + expected <- c("scan_csv", "filter", "col", "group_by", "agg", "all", "sum") + for (i in seq_along(positions)) { + code <- paste0("library(polars)\n", substr(query, 1L, positions[[i]])) + expect_true(expected[[i]] %in% member_labels(code, list(polars = snapshot)), info = code) + } + expect_true("collect" %in% member_labels(paste0("library(polars)\n", query, "\nq$"), list(polars = snapshot))) + expect_true("numeric" %in% member_labels("polars::cs$", list(polars = snapshot))) + expect_length(member_labels("pl$", list(polars = snapshot)), 0L) + expect_length(member_labels("library(polars)\npl <- unknown\npl$", list(polars = snapshot)), 0L) + expect_length(member_labels("library(polars)\nf <- function(pl) {pl$\n}", + list(polars = snapshot), + point = list(row = 1L, col = 23L) + ), 0L) + marker <- tempfile() + on.exit(unlink(marker)) + code <- sprintf( + "library(polars)\npl$scan_csv({writeLines(\"ran\",%s); stop(\"input\")})$filter(stop(\"predicate\"))$", + encodeString(marker, quote = "\"") + ) + expect_true("collect" %in% member_labels(code, list(polars = snapshot))) + expect_false(file.exists(marker)) + changed <- snapshot + rewrite <- function(node) { + if (missing(node)) { + return(node) + } + if (is.symbol(node) && identical(as.character(node), ".savvy_wrap_PlRLazyFrame")) { + return(as.name(".savvy_wrap_PlRDataFrame")) + } + if (is.call(node)) { + return(as.call(lapply(as.list(node), rewrite))) + } + node + } + changed$definitions$PlRLazyFrame_filter <- rewrite(changed$definitions$PlRLazyFrame_filter) + idx <- member_index_thaw(changed) + expect_identical(member_infer(quote(pl$scan_csv(x)$filter(y)), idx, idx$roots)$type, "polars_data_frame") + expect_identical(unserialize(serialize(snapshot, NULL)), snapshot) +}) + +test_that("LSP completion returns member identity and preserves calls", { + fixture <- member_fixture("factory <- function() list(run=function(arg=1) list(done=1))\nfactory()$ru()") + fixture$point <- list(row = 1L, col = 12L) + reply <- completion_reply( + 1L, fixture$document$uri, fixture$workspace, fixture$document, + fixture$point, list(completionItem = list(snippetSupport = TRUE)) + ) + item <- reply$result$items[[1L]] + expect_identical(item$label, "run") + expect_identical(item$textEdit$newText, "run") + expect_identical(item$data$type, "member") + expect_match(item$data$signature, "arg") + resolved <- completion_item_resolve_reply( + 2L, fixture$workspace, item, + list(completionItem = list(labelDetailsSupport = TRUE)) + ) + expect_match(resolved$result$labelDetails$detail, "arg") + expect_true("$" %in% unlist(CompletionOptions$triggerCharacters)) +}) + +test_that("Package metadata fingerprints follow actual API changes", { + env <- new.env(parent = emptyenv()) + env$one <- function(x) list(a = x) + first <- digest::digest(member_snapshot(env), algo = "sha256") + env$two <- function(x, y = 1) list(b = y) + second <- digest::digest(member_snapshot(env), algo = "sha256") + expect_false(identical(first, second)) + env$one <- function(x) list(replaced = x) + expect_false(identical(second, digest::digest(member_snapshot(env), algo = "sha256"))) +}) + +test_that("Unknown branch writes and unrecognized dollar dispatch stay conservative", { + expect_length(member_labels("x <- list(a=1)\nif (unknown) x <- opaque()\nx$"), 0L) + expect_length(member_labels("x <- structure(list(a=list(b=1)),class=\"custom\")\nx$a$"), 0L) +}) + +test_that("Literal custom namespace registration is document local", { + skip_if_not_installed("polars") + snapshot <- member_prepare_package("polars") + code <- paste(c( + "library(polars)", + "shortcuts <- function(s) {self <- new.env(); self$`_s` <- s; self$square <- function() self$`_s`*self$`_s`; class(self) <- c(\"custom_namespace\",\"polars_object\"); self}", + "pl$api$register_series_namespace(\"math\", shortcuts)", + "s <- as_polars_series(1:3)", "s$math$square()$" + ), collapse = "\n") + expect_true("rename" %in% member_labels(code, list(polars = snapshot))) + expect_false("math" %in% member_labels("library(polars)\nas_polars_series(1:3)$", list(polars = snapshot))) +}) + +test_that("Installed Polars namespaces preserve distinct result and signature identities", { + skip_if_not_installed("polars") + snapshot <- member_prepare_package("polars") + index <- member_index_thaw(snapshot) + expected <- c( + "pl$col(\"a\")$str$to_uppercase()" = "polars_expr", + "pl$Series(\"a\",1:3)$str$to_uppercase()" = "polars_series", + "pl$DataFrame(a=1:3)$lazy()" = "polars_lazy_frame", + "pl$when(pl$col(\"a\")>0)$then(1)$otherwise(0)" = "polars_expr" + ) + for (code in names(expected)) { + expect_identical( + member_infer(parse(text = code)[[1L]], index, index$roots)$type, + unname(expected[[code]]), + info = code + ) + } + items <- member_items("library(polars)\npl$all()$su", list(polars = snapshot)) + item <- items[[which(vapply(items, `[[`, character(1L), "label") == "sum")]] + expect_identical(item$data$function_id, "expr__sum") + expect_identical(item$data$package, "polars") +}) + +test_that("Deferred values, dispatch hooks and defaults are never evaluated", { + marker <- tempfile() + on.exit(unlink(marker)) + code <- sprintf(paste0( + "f <- function(x={writeLines(\"ran\",%s);stop(\"default\")}) list(done=1)\n", + "f()$" + ), encodeString(marker, quote = "\"")) + expect_identical(member_labels(code), "done") + expect_false(file.exists(marker)) + code <- paste0( + "`$.custom` <- function(x,name) stop(\"dispatch\")\n", + "`.DollarNames.custom` <- function(x,pattern) stop(\"hook\")\n", + "x <- structure(list(a=1),class=\"custom\")\nx$" + ) + expect_length(member_labels(code), 0L) +}) + +test_that("Local branch writes and later builtin shadowing respect position", { + expect_length(member_labels("f <- function() {x <- list(a=1); if(flag) x <- opaque(); x$\n}", + point = list(row = 0L, col = 72L) + ), 0L) + expect_identical(member_labels("x <- list(a=1)\nx$\nlist <- function(...) unknown()", + point = list(row = 1L, col = 2L) + ), "a") +}) + +test_that("Invalid empty binding names cannot break document parsing", { + content <- c("\"\" <- 2", "assign(\"\", 3)", "d1 <- 1") + parsed <- parse_document("file:///invalid.R", content) + expect_true("d1" %in% names(parsed$definitions)) + expect_true("d1" %in% names(parsed$member_data$bindings)) +}) + +test_that("Metadata resolution survives edits with unchanged package requests", { + uri <- "file:///resolution.R" + document <- Document$new(uri, version = 2L, content = "library(fixture)") + document$requested_packages <- "fixture" + docs <- collections::dict() + docs$set(uri, document) + metadata <- collections::dict() + workspace <- list( + documents = docs, member_metadata = metadata, + load_packages = function(...) NULL, update_loaded_packages = function(...) NULL + ) + self <- list(get_workspace = function(...) workspace) + snapshot <- member_index_freeze(member_generic_index("")) + resolve_callback(self, uri, 1L, list(packages = "fixture", members = list(fixture = snapshot), requested = "fixture")) + expect_true(metadata$has("fixture")) + metadata$clear() + resolve_callback(self, uri, 1L, list(packages = "other", members = list(other = snapshot), requested = "other")) + expect_false(metadata$has("other")) +}) + +test_that("Package extraction follows registries and factories with unrelated names", { + marker <- tempfile() + on.exit(unlink(marker)) + code <- paste(c( + "api <- new.env(parent=emptyenv())", + "commands <- new.env(parent=emptyenv())", + "tools <- new.env(parent=emptyenv())", + "machine <- new.env(parent=emptyenv())", + "native_box <- function(pointer) {box <- new.env(); box$ptr <- pointer; box$advance <- 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) {object <- new.env(); object$raw <- x; lapply(names(tools), function(label) makeActiveBinding(label,function() tools[[label]](object),object)); class(object) <- \"public_box\"; object}", + "toolbox <- function(x) {object <- new.env(); object$raw <- x$raw; class(object) <- \"box_tools\"; object}", + "`$.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()}", + "`$.box_tools` <- 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) adapt(current$raw$advance(delta))", + "commands$step <- step", + "tools$tools <- toolbox", + "machine$create <- function(input) native_box(.Call(\"never\",input))", + "api$start <- function(input) adapt(machine$create(input))", + "api$settings <- commands" + ), collapse = "\n") + scope <- new.env(parent = baseenv()) + # Execute only the trusted package fixture's declarations, like package + # loading. Constructors and methods are never run by metadata preparation. + eval(parse(text = code), scope) + input <- member_namespace_input(scope, package = "fluentfixture", exports = c("api", "adapt")) + snapshot <- member_index_freeze(member_package_index(input)) + expect_true("step" %in% member_labels("library(fluentfixture)\napi$start(stop(\"input\"))$", list(fluentfixture = snapshot))) + expect_true("step" %in% member_labels("library(fluentfixture)\napi$start(x)$step()$tools$", list(fluentfixture = snapshot))) + expect_true("step" %in% member_labels("library(fluentfixture)\napi$settings$", list(fluentfixture = snapshot))) + index <- member_index_thaw(snapshot) + expect_identical(member_infer(quote(api$start(x)$step(2)$tools$step()), index, index$roots)$type, "public_box") + scope$commands$finish <- function() list(completed = TRUE) + updated <- member_index_freeze(member_package_index(member_namespace_input(scope, + package = "fluentfixture", exports = c("api", "adapt") + ))) + expect_true("finish" %in% member_labels("library(fluentfixture)\napi$start(x)$", list(fluentfixture = updated))) + expect_false(identical(snapshot$generation, updated$generation)) + expect_false(file.exists(marker)) +}) + +test_that("Delegation extraction derives captures and result bodies", { + code <- paste(c( + "api <- new.env(parent=emptyenv()); commands <- new.env(parent=emptyenv())", + "original <- function(amount=1) list(ignored=amount)", + "commands$run <- original", + "api$start <- function(input) {object <- new.env(); object$payload <- input; class(object) <- \"delegating_box\"; object}", + "build_delegate <- function(method,object) {saved <- object$payload; generated <- function() list(result=saved); formals(generated) <- formals(method); generated}", + "`$.delegating_box` <- function(x,name) {allowed <- names(commands); if(name %in% allowed) {selected <- commands[[name]]; build_delegate(selected,x)} else NextMethod()}" + ), collapse = "\n") + scope <- new.env(parent = baseenv()) + eval(parse(text = code), scope) + index <- member_package_index(member_namespace_input(scope, package = "delegationfixture", exports = "api")) + value <- member_infer(quote(api$start(list(nested = 1))$run()$result), index, index$roots) + expect_identical(names(value$fields), "nested") + snapshot <- member_index_freeze(index) + items <- member_items("library(delegationfixture)\napi$start(x)$ru", list(delegationfixture = snapshot)) + expect_match(items[[1L]]$data$signature, "amount") + expect_identical(items[[1L]]$data$function_id, "original") +}) + +test_that("Installed S7 descriptors expose declarations without calling constructors", { + skip_if_not_installed("S7") + marker <- tempfile() + on.exit(unlink(marker)) + scope <- new.env(parent = baseenv()) + scope$api <- new.env(parent = emptyenv()) + scope$Widget <- S7::new_class("Widget", + properties = list(size = S7::class_numeric), + constructor = function(...) { + writeLines("ran", marker) + stop("constructor") + S7::new_object(S7::S7_object(), size = 1) + } + ) + scope$api$Widget <- scope$Widget + index <- member_package_index(member_namespace_input(scope, package = "s7fixture", exports = "api")) + value <- member_infer(quote(api$Widget()), index, index$roots) + expect_identical(value$type, "Widget") + expect_true("size" %in% names(member_members(value, index))) + expect_false(file.exists(marker)) +}) diff --git a/tests/testthat/test-member-providers.R b/tests/testthat/test-member-providers.R new file mode 100644 index 00000000..0fafda3d --- /dev/null +++ b/tests/testthat/test-member-providers.R @@ -0,0 +1,338 @@ +member_provider_fixture <- function(lines, snapshots = list(), language = "r") { + uri <- if (language == "r") "file:///member-provider.R" else "file:///member-provider.qmd" + document <- Document$new(uri, language = language, version = 1L, content = lines) + data <- parse_document(uri, lines, is_rmarkdown = document$is_rmarkdown) + data$version <- 1L + document$update_parse_data(data) + metadata <- collections::dict() + for (package in names(snapshots)) metadata$set(package, member_index_thaw(snapshots[[package]])) + workspace <- list( + member_metadata = metadata, + get_documentation = function(...) NULL, + get_signature = function(...) stop("unrelated bare function lookup"), + get_help = function(...) stop("unrelated bare help lookup") + ) + list(uri = uri, document = document, workspace = workspace) +} + +member_provider_signature <- function( + fixture, row = fixture$document$nline - 1L, + col = nchar(fixture$document$line0(row)) +) { + signature_reply( + 1L, fixture$uri, fixture$workspace, fixture$document, + list(row = row, col = col) + )$result +} + +member_provider_hover <- function(fixture, row, col) { + hover_reply( + 1L, fixture$uri, fixture$workspace, fixture$document, + list(row = row, col = col) + )$result +} + +test_that("Multiline dollar chains share completion, signatures and hover", { + code <- c( + "make_pipeline <- function(source) {", + "self <- new.env(parent = emptyenv())", + "self$source <- source", + "self$filter <- function(predicate) self", + "self$limit <- function(n = 10L) self", + "self$collect <- function(format = \"list\") {", + "list(data = source, format = format, metadata = list(cached = FALSE))", + "}", "self", "}", "pipeline <- make_pipeline(iris)", + "pipeline$", " filter(\"Sepal.Length > 5\")$", " limit(n = 5)$", + " filter(\"Petal.Length < 2\")$", " collect()" + ) + fixture <- member_provider_fixture(code) + for (row in 11:15) { + col <- if (row == 11L) 9L else 4L + items <- member_completion(fixture$uri, fixture$workspace, fixture$document, list(row = row, col = col), TRUE, 200L) + labels <- vapply(items, `[[`, character(1L), "label") + expected <- if (row == 11L) c("collect", "filter", "limit", "source") else if (row == 13L) "limit" else if (row == 15L) "collect" else "filter" + expect_identical(labels, expected) + if (row > 11L) { + expect_identical(items[[1L]]$textEdit$range$start$line, row) + expect_identical(items[[1L]]$textEdit$range$start$character, 2L) + expect_false(grepl("[(]", items[[1L]]$textEdit$newText)) + } + } + for (row in 12:15) { + col <- regexpr("[(]", code[[row + 1L]])[[1L]] + expected <- if (row == 13L) "limit(n = 10L)" else if (row == 15L) "collect(format = \"list\")" else "filter(predicate)" + expect_identical(member_provider_signature(fixture, row, col)$signatures[[1L]]$label, expected) + expect_identical(member_provider_hover(fixture, row, 4L)$contents, sprintf("```r\n%s\n```", expected)) + } + fixture <- member_provider_fixture(c(code[1:11], "pipeline$ # continue", " # comment", "", " collect(format = ")) + expect_identical(member_provider_signature(fixture)$signatures[[1L]]$label, "collect(format = \"list\")") + expect_identical(member_provider_hover(fixture, 14L, 4L)$range$start$character, 2L) + fixture <- member_provider_fixture(c("x <- list(`a b`=function(value=1) NULL)", "x$", " `a b`(")) + expect_identical(member_provider_signature(fixture)$signatures[[1L]]$label, "`a b`(value = 1)") + expect_identical(member_provider_hover(fixture, 2L, 4L)$contents, "```r\n`a b`(value = 1)\n```") + for (lines in list(c("x <- list(run=function() NULL)", "\"x$\"", "run("), + c("x <- list(run=function() NULL)", "# x$", "run("))) { + fixture <- member_provider_fixture(lines) + expect_null(member_hover_location(fixture$document, list(row = 2L, col = 2L))) + expect_null(member_symbol(fixture$uri, fixture$workspace, fixture$document, + member_call_location(fixture$document, list(row = 2L, col = 4L)))$signature) + } +}) + +test_that("R6 self, super and private refer to their declared method contexts", { + parent <- paste0("Parent <- R6::R6Class(\"Parent\", public=list(run=function(value=1) self, base=42),", + "private=list(inherited=function(key=2) self), active=list(parent_active=function() stop(\"getter\")))") + code <- c(parent, "Child <- R6::R6Class(\"Child\", inherit=Parent,", "public=list(", + "test=function() {", " self$child(option = TRUE)", " super$run(value = 2)", "},", + "child=function(option=FALSE) self),", "private=list(secret=function(key=1) NULL),", + "active=list(current=function() self$child()))") + fixture <- member_provider_fixture(code) + for (case in list(list(row = 4L, col = 7L, expected = c("base", "child", "current", "parent_active", "run", "test")), + list(row = 5L, col = 8L, expected = c("inherited", "parent_active", "run")))) { + items <- member_completion(fixture$uri, fixture$workspace, fixture$document, case[c("row", "col")], TRUE, 200L) + expect_identical(vapply(items, `[[`, character(1L), "label"), case$expected) + } + expect_identical(member_provider_hover(fixture, 4L, 10L)$contents, "```r\nchild(option = FALSE)\n```") + expect_identical(member_provider_hover(fixture, 5L, 10L)$contents, "```r\nrun(value = 1)\n```") + expect_identical(member_provider_signature(fixture, 4L, 14L)$signatures[[1L]]$label, "child(option = FALSE)") + expect_identical(member_provider_hover(fixture, 9L, 37L)$contents, "```r\nchild(option = FALSE)\n```") + + fixture <- member_provider_fixture(c(parent, "Child <- R6::R6Class(\"Child\", inherit=Parent,", + "private=list(test=function() private$secret(), secret=function(key=1) NULL))")) + expect_identical(member_provider_hover(fixture, 2L, 42L)$contents, "```r\nsecret(key = 1)\n```") + fixture <- member_provider_fixture(c(parent, "Child <- R6::R6Class(\"Child\", inherit=Parent,", + "public=list(test=function(self) self$run()))")) + expect_null(member_provider_hover(fixture, 2L, 38L)) + fixture <- member_provider_fixture(c("f <- function() self$run()")) + expect_null(member_provider_hover(fixture, 0L, 23L)) + # A trailing parse error cannot remove the class context before it. + fixture <- member_provider_fixture(c(code, "broken <- )")) + expect_identical(member_provider_hover(fixture, 4L, 10L)$contents, "```r\nchild(option = FALSE)\n```") + fixture <- member_provider_fixture(c(parent, "Child <- R6::R6Class(\"Child\", inherit=Parent,", + "public=list(test=function() super$run()$child(), child=function(option=FALSE) self))")) + expect_identical(member_provider_hover(fixture, 2L, 42L)$contents, "```r\nchild(option = FALSE)\n```") + fixture <- member_provider_fixture(c(parent, "Child <- R6::R6Class(\"Child\", inherit=Parent,", + "public=list(test=function() {self <- list(local=1); self$local}))")) + expect_identical(member_provider_hover(fixture, 2L, 59L)$contents, "```r\n1\n```") + fixture <- member_provider_fixture(c("```{r}", code, "```", "```{python}", "self$child()", "```"), language = "quarto") + expect_identical(member_provider_hover(fixture, 5L, 10L)$contents, "```r\nchild(option = FALSE)\n```") + expect_null(member_call_location(fixture$document, list(row = 13L, col = 11L))) +}) + +test_that("Multiline members and R6 method context work on the first LSP request after edits", { + skip_on_cran() + client <- language_client() + path <- withr::local_tempfile(fileext = ".R") + uri <- path_to_uri(path) + declarations <- c("x <- list(run=function(value=1) NULL)") + did_open(client, path, text = declarations) + notify(client, "workspace/didChangeConfiguration", list(settings = list(parse_delay = 0.5))) + edit <- function(lines, version) { + notify(client, "textDocument/didChange", list(textDocument = list(uri = uri, version = version), + contentChanges = list(list(text = paste(lines, collapse = "\n"))))) + } + edit(c(declarations, "x$", " ru"), 2L) + result <- respond_completion(client, path, c(2L, 4L), retry = FALSE) + expect_identical(vapply(result$items, `[[`, character(1L), "label"), "run") + edit(c(declarations, "x$", " run(value = "), 3L) + expect_identical(respond_signature(client, path, c(2L, 14L), retry = FALSE)$signatures[[1L]]$label, "run(value = 1)") + edit(c(declarations, "x$", " run()"), 4L) + expect_identical(respond_hover(client, path, c(2L, 4L), retry = FALSE)$contents[[1L]], "```r\nrun(value = 1)\n```") + code <- c("Parent <- R6::R6Class(\"Parent\", public=list(run=function(value=1) self))", + "Child <- R6::R6Class(\"Child\", inherit=Parent, public=list(", + "test=function() {self$},", "child=function(flag=TRUE) self))") + edit(code, 5L) + result <- respond_completion(client, path, c(2L, 22L), retry = FALSE) + expect_setequal(vapply(result$items, `[[`, character(1L), "label"), c("run", "test", "child")) + code[[3L]] <- "test=function() super$run()," + edit(code, 6L) + expect_identical(respond_hover(client, path, c(2L, 24L), retry = FALSE)$contents[[1L]], "```r\nrun(value = 1)\n```") +}) + +test_that("Member signatures follow fluent source closures without calling arguments", { + marker <- withr::local_tempfile() + fixture <- member_provider_fixture(c( + "factory <- function(x) list(step=function() list(finish=function(value, flag=TRUE) x))", + sprintf( + "factory({writeLines(\"ran\", %s); stop(\"input\")})$step()$finish(flag = ", + encodeString(marker, quote = "\"") + ) + )) + result <- member_provider_signature(fixture) + expect_identical(result$signatures[[1L]]$label, "finish(value, flag = TRUE)") + expect_identical(result$activeParameter, 1L) + expect_length(result$signatures[[1L]]$parameters, 2L) + expect_false(file.exists(marker)) + + fixture <- member_provider_fixture(c( + "x <- list(run=function(first, ..., option=TRUE) NULL)", "x$run(", + " first=1,", " option = " + )) + expect_identical(member_provider_signature(fixture)$activeParameter, 2L) + fixture <- member_provider_fixture(c( + "f <- function() {x <- list(run=function(local=1) NULL); x$run(", "}" + )) + expect_identical(member_provider_signature(fixture, 0L)$signatures[[1L]]$label, "run(local = 1)") +}) + +test_that("Member hover preserves quoted names, fields and UTF-16 ranges", { + fixture <- member_provider_fixture(c( + "x <- list(`a b`=function(value=1) NULL, answer=42)", + "\"\U0001f680\"; x$`a b`(value=1)", "x$answer" + )) + for (col in 7:12) { + result <- member_provider_hover(fixture, 1L, col) + expect_identical(result$contents, "```r\n`a b`(value = 1)\n```") + expect_identical(result$range$start$character, 8L) + expect_identical(result$range$end$character, 13L) + } + expect_identical( + member_provider_signature(fixture, 1L, 20L)$signatures[[1L]]$label, + "`a b`(value = 1)" + ) + expect_identical(member_provider_hover(fixture, 2L, 4L)$contents, "```r\n42\n```") +}) + +test_that("R6 members use public inherited declarations without initialization or getters", { + fixture <- member_provider_fixture(c( + "Parent <- R6::R6Class(\"Parent\", public=list(run=function(value, option=FALSE) self))", + "Child <- R6::R6Class(\"Child\", inherit=Parent, public=list(initialize=function() stop(\"initialize\")),", + "active=list(danger=function() stop(\"getter\")))", "Child$new()$run(option = " + )) + expect_identical( + member_provider_signature(fixture)$signatures[[1L]]$label, + "run(value, option = FALSE)" + ) + expect_identical( + member_provider_hover(fixture, 3L, 13L)$contents, + "```r\nrun(value, option = FALSE)\n```" + ) + fixture$document$set_content(2L, c(fixture$document$content[1:3], "Child$new()$danger")) + data <- parse_document(fixture$uri, fixture$document$content) + data$version <- 2L + fixture$document$update_parse_data(data) + expect_null(member_provider_hover(fixture, 3L, 14L)) +}) + +test_that("Unknown and shadowed member receivers never resolve unrelated bare functions", { + for (lines in list( + c("unknown$sum("), + c("x <- list(sum=function(value) NULL)", "f <- function(x) {x$sum(", "}"), + c("x <- list(sum=function(value) NULL)", "x <- opaque()", "x$sum(") + )) { + fixture <- member_provider_fixture(lines) + row <- if (endsWith(tail(lines, 1L), "}")) length(lines) - 2L else length(lines) - 1L + expect_length(member_provider_signature(fixture, row)$signatures, 0L) + col <- regexpr("sum", lines[[row + 1L]])[[1L]] + expect_null(member_provider_hover(fixture, row, col)) + } + fixture <- member_provider_fixture(c("x <- list(sum=function(value) NULL)", "# x$sum(")) + expect_length(member_provider_signature(fixture)$signatures, 0L) + expect_null(member_provider_hover(fixture, 1L, 6L)) +}) + +test_that("Member providers stay inside R cells", { + fixture <- member_provider_fixture(c( + "```{r}", "x <- list(run=function(value=1) NULL)", + "x$run(", "```", "```{python}", "x$run(", "```" + ), language = "quarto") + expect_identical(member_provider_signature(fixture, 2L)$signatures[[1L]]$label, "run(value = 1)") + expect_identical(member_provider_hover(fixture, 2L, 3L)$contents, "```r\nrun(value = 1)\n```") + expect_null(member_provider_hover(fixture, 5L, 3L)) + expect_null(member_provider_signature(fixture, 5L)$signatures) +}) + +test_that("Installed package members retain method signatures and documentation identity", { + skip_if_not_installed("polars") + snapshot <- member_prepare_package("polars") + fixture <- member_provider_fixture(c( + "library(polars)", "q <- pl$scan_csv(csv_file)", + "q$group_by(\"Species\", .maintain_order = " + ), list(polars = snapshot)) + queried <- character() + fixture$workspace$get_documentation <- function(key, package, isf, uri) { + expect_identical(package, "polars") + expect_identical(uri, fixture$uri) + queried <<- c(queried, key) + list( + description = paste("Documentation for", key), + arguments = list(.maintain_order = "Preserve group order.") + ) + } + signature <- member_provider_signature(fixture) + expect_identical(signature$signatures[[1L]]$label, "group_by(..., .maintain_order = FALSE)") + expect_identical(signature$activeParameter, 1L) + hover <- member_provider_hover(fixture, 2L, 5L) + expect_match(hover$contents[[2L]], "lazyframe__group_by", fixed = TRUE) + argument <- member_provider_hover(fixture, 2L, 25L) + expect_identical(argument$contents[[1L]], "```r\ngroup_by(..., .maintain_order = FALSE)\n```") + expect_identical(argument$contents[[2L]], "`.maintain_order` - Preserve group order.") + expect_true(all(queried == "lazyframe__group_by")) + + for (case in list( + c("pl$col(\"x\")$sum(", "expr__sum"), + # Series delegates this operation to Expr and copies its formals. + c("pl$Series(\"x\", 1:3)$sum(", "expr__sum"), + c("pl$col(\"x\")$str$to_uppercase(", "expr_str_to_uppercase") + )) { + fixture$document$set_content(2L, c("library(polars)", case[[1L]])) + data <- parse_document(fixture$uri, fixture$document$content) + data$version <- 2L + fixture$document$update_parse_data(data) + result <- member_provider_signature(fixture) + expect_length(result$signatures, 1L) + expect_identical(tail(queried, 1L), case[[2L]]) + col <- nchar(case[[1L]]) - 2L + hover <- member_provider_hover(fixture, 1L, col) + expect_match(hover$contents[[2L]], case[[2L]], fixed = TRUE) + } + fixture$document$set_content(3L, c("library(polars)", "pl$scan_csv(csv_file)$`_ldf`$collect(")) + data <- parse_document(fixture$uri, fixture$document$content) + data$version <- 3L + fixture$document$update_parse_data(data) + expect_identical(member_provider_signature(fixture)$signatures[[1L]]$label, "collect(engine)") + expect_identical(tail(queried, 1L), "PlRLazyFrame_collect") +}) + +test_that("Member signature and hover work over LSP immediately after an edit", { + skip_on_cran() + skip_if_not_installed("polars") + client <- language_client() + path <- withr::local_tempfile(fileext = ".R") + uri <- path_to_uri(path) + lines <- c("library(polars)", "q <- pl$scan_csv(csv_file)", "q$group_by(\"Species\")") + did_open(client, path, text = paste(lines, collapse = "\n")) + deadline <- Sys.time() + 15 + repeat { + ready <- respond_completion(client, path, c(2L, 2L), retry = FALSE) + if (any(vapply(ready$items, function(item) identical(item$data$type, "member"), logical(1L)))) break + if (Sys.time() > deadline) break + Sys.sleep(0.1) + } + expect_true(any(vapply(ready$items, function(item) identical(item$data$type, "member"), logical(1L)))) + notify(client, "workspace/didChangeConfiguration", list(settings = list(parse_delay = 0.5))) + lines[[3L]] <- "q$group_by(\"Species\", .maintain_order = " + notify(client, "textDocument/didChange", list( + textDocument = list(uri = uri, version = 2L), + contentChanges = list(list(text = paste(lines, collapse = "\n"))) + )) + # No request retry or delay after didChange: the handler must wait for the + # current incomplete parse, then infer the method on the first request. + result <- respond_signature(client, path, c(2L, nchar(lines[[3L]])), retry = FALSE) + expect_identical(result$signatures[[1L]]$label, "group_by(..., .maintain_order = FALSE)") + expect_equal(result$activeParameter, 1L) + expect_match(result$signatures[[1L]]$documentation$value, "group", ignore.case = TRUE) + + lines[[3L]] <- "q$group_by(\"Species\", .maintain_order = TRUE)" + notify(client, "textDocument/didChange", list( + textDocument = list(uri = uri, version = 3L), + contentChanges = list(list(text = paste(lines, collapse = "\n"))) + )) + hover <- respond_hover(client, path, c(2L, 5L), retry = FALSE) + expect_identical(hover$contents[[1L]], "```r\ngroup_by(..., .maintain_order = FALSE)\n```") + expect_match(hover$contents[[2L]], "group", ignore.case = TRUE) + expect_equal(hover$range$start$character, 2L) + expect_equal(hover$range$end$character, 10L) + argument <- respond_hover(client, path, c(2L, 25L), retry = FALSE) + expect_match(argument$contents[[2L]], "`.maintain_order`", fixed = TRUE) +}) diff --git a/tests/testthat/test-member-s4.R b/tests/testthat/test-member-s4.R new file mode 100644 index 00000000..86607e2b --- /dev/null +++ b/tests/testthat/test-member-s4.R @@ -0,0 +1,248 @@ +s4_fixture <- function(lines, snapshots = list(), point = NULL, language = "r") { + uri <- if (language == "r") "file:///s4-members.R" else "file:///s4-members.qmd" + document <- Document$new(uri, language = language, version = 1L, content = lines) + data <- parse_document(uri, lines, is_rmarkdown = document$is_rmarkdown) + data$version <- 1L + document$update_parse_data(data) + metadata <- collections::dict() + for (package in names(snapshots)) metadata$set(package, member_index_thaw(snapshots[[package]])) + workspace <- list(member_metadata = metadata, get_documentation = function(...) NULL) + if (is.null(point)) point <- list(row = length(lines) - 1L, col = nchar(tail(lines, 1L))) + list(uri = uri, document = document, workspace = workspace, point = point) +} + +s4_items <- function(lines, snapshots = list(), point = NULL, language = "r") { + fixture <- s4_fixture(lines, snapshots, point, language) + member_completion(fixture$uri, fixture$workspace, fixture$document, fixture$point, TRUE, 200L) +} + +s4_labels <- function(...) vapply(s4_items(...), `[[`, character(1L), "label") + +test_that("S4 slots follow declarations, inheritance, factories and aliases", { + declarations <- c( + "setClass(\"Parent\", slots=c(value=\"numeric\"))", + "Widget <- methods::setClass(\"Widget\", contains=\"Parent\", slots=list(label=\"character\"))" + ) + expect_identical(s4_labels(c(declarations, "x <- new(\"Widget\")", "y <- x", "y@")), c("label", "value")) + expect_identical(s4_labels(c(declarations, "Widget()@")), c("label", "value")) + expect_identical(s4_labels(c( + declarations, + "factory <- function(x) new(\"Widget\", value=x)", + "factory(stop(\"must not run\"))@" + )), c("label", "value")) + expect_identical(s4_labels(c( + "setClass(\"Legacy\", representation(value=\"numeric\", \"Parent\"))", + declarations[[1L]], "new(\"Legacy\")@" + )), "value") + expect_identical(s4_labels(c( + "factory <- function() {setClass(\"Local\", slots=c(value=\"numeric\")); new(\"Local\")}", + "factory()@" + )), "value") + expect_identical(s4_labels(c( + "setClass(\"Vector\", contains=\"numeric\", slots=c(label=\"character\"))", + "new(\"Vector\")@" + )), c(".Data", "label")) + expect_true("@" %in% unlist(CompletionOptions$triggerCharacters)) + expect_identical(s4_labels(c("setClass(\"Store\", contains=\"environment\")", "new(\"Store\")@")), ".xData") +}) + +test_that("S4 nested slots retain declared and supplied structures", { + declarations <- c( + "setClass(\"Leaf\", slots=c(value=\"numeric\"))", + "setClass(\"Tree\", slots=c(leaf=\"Leaf\", items=\"list\"))" + ) + expect_identical(s4_labels(c(declarations, "new(\"Tree\")@leaf@")), "value") + expect_identical(s4_labels(c(declarations, "new(\"Tree\", items=list(alpha=1))@items$")), "alpha") + expect_identical(s4_labels(c(declarations, "methods::slot(new(\"Tree\"), \"leaf\")@")), "value") + expect_length(s4_labels(c(declarations, "new(\"Tree\")$")), 0L) + expect_length(s4_labels("list(value=1)@"), 0L) + expect_length(s4_labels(c(declarations, "new(\"Tree\")@missing@")), 0L) + expect_identical(s4_labels(c( + "setClass(\"A\", slots=c(common=\"numeric\", a=\"character\"))", + "setClass(\"B\", slots=c(common=\"numeric\", b=\"character\"))", + "setClassUnion(\"Either\", c(\"A\", \"B\"))", + "setClass(\"Box\", slots=c(item=\"Either\"))", "new(\"Box\")@item@" + )), "common") +}) + +test_that("S4 slot completion recovers edits and quotes names", { + declaration <- "setClass(\"Widget\", slots=c(`a b`=\"numeric\", beta=\"character\"))" + expect_identical(s4_labels(c("bad <- )", declaration, "new(\"Widget\") @ be")), "beta") + items <- s4_items(c(declaration, "x <- new(\"Widget\")", "x@`a")) + expect_identical(items[[1L]]$textEdit$newText, "`a b`") + expect_identical(items[[1L]]$textEdit$range$start$character, 2L) + expect_identical(items[[1L]]$detail, "a b: numeric") + expect_length(s4_labels(c(declaration, "# x@")), 0L) + expect_length(s4_labels(c(declaration, "\"x@\"")), 0L) + item <- s4_items(c(declaration, "x <- new(\"Widget\")", "\"\U0001f680\"; x@beXYZ"), point = list(row = 2L, col = 9L))[[1L]] + expect_identical(item$textEdit$range$start$character, 8L) + expect_identical(item$textEdit$range$end$character, 13L) + expect_identical(s4_labels(c("```{r}", declaration, "new(\"Widget\")@", "```"), + point = list(row = 2L, col = 14L), language = "quarto"), c("a b", "beta")) + expect_length(s4_labels(c("```{r}", declaration, "```", "```{python}", "new(\"Widget\")@", "```"), + point = list(row = 4L, col = 14L), language = "quarto"), 0L) +}) + +test_that("S4 declarations remain conservative around shadowing and unknown types", { + declaration <- "setClass(\"Widget\", slots=c(value=\"numeric\"))" + expect_length(s4_labels(c("new(\"Widget\")@", declaration), point = list(row = 0L, col = 14L)), 0L) + expect_length(s4_labels(c(declaration, "new <- function(...) unknown()", "new(\"Widget\")@")), 0L) + expect_identical(s4_labels(c(declaration, "new <- function(...) unknown()", "methods::new(\"Widget\")@")), "value") + expect_length(s4_labels(c("setClass <- function(...) NULL", declaration, "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c(declaration, "new(class_name)@")), 0L) + expect_length(s4_labels(c("setClass(\"Widget\", slots=dynamic)", "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c("c <- function(...) unknown", declaration, "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c("list <- function(...) unknown", "setClass(\"Widget\", slots=list(value=\"numeric\"))", "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c("setClass(\"Widget\", contains=\"Unknown\")", "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c("setClass(\"Widget\", contains=\"Widget\")", "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c("setClass(\"Widget\", contains=\"VIRTUAL\")", "new(\"Widget\")@")), 0L) + expect_identical(s4_labels(c(declaration, "setClass(\"Widget\", slots=c(changed=\"logical\"))", "new(\"Widget\")@")), "changed") + expect_length(s4_labels(c("setClass(\"Widget\", slots=c(value=))", "new(\"Widget\")@")), 0L) + expect_length(s4_labels(c("setClass(Class=, slots=c(value=\"numeric\"))", "new(\"Widget\")@")), 0L) +}) + +test_that("S4 hover and signatures use known function slot syntax without execution", { + marker <- withr::local_tempfile() + declarations <- c( + "setClass(\"Widget\", slots=c(value=\"numeric\", run=\"function\"),", + "prototype=list(run=function(value, flag=TRUE) value), validity=function(object) stop(\"validity\"))", + "setMethod(\"initialize\", \"Widget\", function(.Object, ...) stop(\"initialize\"))", + "x <- new(\"Widget\")" + ) + fixture <- s4_fixture(c(declarations, "x@run(flag = ")) + signature <- signature_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result + expect_identical(signature$signatures[[1L]]$label, "run(value, flag = TRUE)") + expect_identical(signature$activeParameter, 1L) + hover <- hover_reply(1L, fixture$uri, fixture$workspace, fixture$document, list(row = 4L, col = 4L))$result + expect_identical(hover$contents, "```r\nrun(value, flag = TRUE)\n```") + fixture <- s4_fixture(c(declarations, "x@value")) + hover <- hover_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result + expect_identical(hover$contents, "```r\ndouble\n```") + + fixture <- s4_fixture(c(declarations, sprintf( + "new(\"Widget\", run=function(first, second=2) NULL)@run({writeLines(\"ran\", %s); stop(\"argument\")}, ", + encodeString(marker, quote = "\"") + ))) + signature <- signature_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result + expect_identical(signature$signatures[[1L]]$label, "run(first, second = 2)") + expect_false(file.exists(marker)) + fixture <- s4_fixture(c("setClass(\"Opaque\", slots=c(run=\"function\"))", "new(\"Opaque\")@run(")) + expect_length(signature_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result$signatures, 0L) +}) + +test_that("Installed S4 metadata supplies current slots without constructing objects", { + skip_if_not_installed("stats4") + snapshot <- member_prepare_package("stats4") + expected <- sort(names(methods::getSlots(methods::getClassDef("mle", where = asNamespace("stats4"))))) + expect_identical(s4_labels(c("library(stats4)", "new(\"mle\")@"), list(stats4 = snapshot)), expected) + expect_identical(s4_labels("stats4::mle(function(x) x^2)@", list(stats4 = snapshot)), expected) + expect_length(s4_labels("new(\"mle\")@", list(stats4 = snapshot)), 0L) + expect_identical(member_index_freeze(member_index_thaw(snapshot))$s4_classes, snapshot$s4_classes) +}) + +test_that("S4 namespace constructors and objects use inert descriptor metadata", { + scope <- new.env(parent = asNamespace("methods")) + name <- paste0("S4Fixture", Sys.getpid()) + scope$Widget <- methods::setClass(name, slots = c(value = "numeric"), where = scope, package = "s4fixture") + withr::defer(suppressWarnings(methods::removeClass(name, where = scope))) + scope$object <- scope$Widget() + store <- paste0(name, "Store") + Store <- methods::setClass(store, contains = "environment", where = scope, package = "languageserver") + withr::defer(suppressWarnings(methods::removeClass(store, where = scope))) + scope$store <- Store() + marker <- withr::local_tempfile() + makeActiveBinding("unsafe", function() { + writeLines("ran", marker) + stop("getter") + }, scope) + input <- member_namespace_input(scope, package = "s4fixture", exports = c("Widget", "object")) + snapshot <- member_index_freeze(member_package_index(input)) + expect_identical(s4_labels(c("library(s4fixture)", "Widget()@"), list(s4fixture = snapshot)), "value") + expect_identical(s4_labels("s4fixture::Widget()@", list(s4fixture = snapshot)), "value") + expect_identical(s4_labels(c("library(s4fixture)", "object@"), list(s4fixture = snapshot)), "value") + store_input <- member_namespace_input(scope, package = "languageserver", exports = "store") + store_snapshot <- member_index_freeze(member_package_index(store_input)) + expect_identical(s4_labels("languageserver::store@", list(languageserver = store_snapshot)), ".xData") + expect_false(file.exists(marker)) + changed <- snapshot + changed$s4_classes[[name]]$slots <- list(changed = "character") + expect_identical(s4_labels("s4fixture::Widget()@", list(s4fixture = changed)), "changed") +}) + +test_that("S4 dependency slots and union branches preserve class package identities", { + skip_if_not_installed("stats4") + loadNamespace("stats4") + classes <- list(Box = list(name = "Box", slots = list(fit = structure("mle", package = "stats4")))) + dependencies <- member_s4_dependencies(classes) + expect_true("mle" %in% names(dependencies$stats4)) + input <- list(package = "s4fixture", definitions = list(), exports = "object", s4_classes = classes, + s4_dependencies = dependencies, s4_objects = list(object = list(name = "Box", package = "s4fixture"))) + snapshot <- member_index_freeze(member_package_index(input)) + expect_true("coef" %in% s4_labels("s4fixture::object@fit@", list(s4fixture = snapshot))) + fixture <- s4_fixture("s4fixture::object@fit@coef", list(s4fixture = snapshot)) + expect_identical(hover_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result$contents, "```r\ndouble\n```") + + index <- member_generic_index("") + index$s4_dependencies <- list( + a = list(Leaf = list(slots = list(common = "numeric", a = "character"))), + b = list(Leaf = list(slots = list(common = "numeric", b = "character"))) + ) + a <- member_value(type = "Box", slot_types = list(item = "Leaf"), s4_class = list(name = "Box", package = "a")) + b <- member_value(type = "Box", slot_types = list(item = "Leaf"), s4_class = list(name = "Box", package = "b")) + nested <- member_s4_slot(member_join(a, b), "item", index, list()) + expect_identical(names(nested$slot_types), "common") +}) + +test_that("S4 source packages, local slot writes and prototype cycles stay static", { + code <- c("Widget <- methods::setClass(\"Widget\", slots=c(value=\"numeric\"))") + input <- list(package = "s4fixture", exports = "Widget", definitions = list(Widget = parse(text = code)[[1L]][[3L]]), + expressions = list(parse(text = code))) + snapshot <- member_index_freeze(member_package_index(input)) + expect_identical(s4_labels("s4fixture::Widget()@", list(s4fixture = snapshot)), "value") + fixture <- s4_fixture(c( + "setClass(\"Widget\", slots=c(run=\"function\"))", + "factory <- function() {x <- new(\"Widget\"); x@run <- function(first, second=2) NULL; x}", + "factory()@run(" + )) + expect_identical(signature_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result$signatures[[1L]]$label, + "run(first, second = 2)") + expect_identical(s4_labels(c( + "setClass(\"Loop\", slots=c(item=\"Loop\"), prototype=list(item=new(\"Loop\")@item))", + "new(\"Loop\")@item@" + )), "item") + index <- member_generic_index("") + index$s4_classes <- list(Widget = list(slots = list(value = "numeric"))) + budget <- new.env(parent = emptyenv()) + budget$remaining <- 0L + expect_identical(member_s4_shape("Widget", index, list(), budget = budget)$reason, "budget") + expect_true(budget$exhausted) +}) + +test_that("S4 providers wait for the first request after an edit over LSP", { + skip_on_cran() + client <- language_client() + path <- withr::local_tempfile(fileext = ".R") + uri <- path_to_uri(path) + lines <- c( + "setClass(\"Widget\", slots=c(value=\"numeric\", run=\"function\"), prototype=list(run=function(value, flag=TRUE) value))", + "x <- new(\"Widget\")", "x" + ) + did_open(client, path, text = paste(lines, collapse = "\n")) + notify(client, "workspace/didChangeConfiguration", list(settings = list(parse_delay = 0.5))) + edit <- function(text, version) { + lines[[3L]] <<- text + notify(client, "textDocument/didChange", list( + textDocument = list(uri = uri, version = version), + contentChanges = list(list(text = paste(lines, collapse = "\n"))) + )) + } + edit("x@", 2L) + result <- respond_completion(client, path, c(2L, 2L), retry = FALSE) + expect_setequal(vapply(result$items, `[[`, character(1L), "label"), c("run", "value")) + edit("x@run(flag = ", 3L) + result <- respond_signature(client, path, c(2L, nchar(lines[[3L]])), retry = FALSE) + expect_identical(result$signatures[[1L]]$label, "run(value, flag = TRUE)") + edit("x@value", 4L) + result <- respond_hover(client, path, c(2L, 4L), retry = FALSE) + expect_identical(result$contents[[1L]], "```r\ndouble\n```") +}) diff --git a/tests/testthat/test-member-s7.R b/tests/testthat/test-member-s7.R new file mode 100644 index 00000000..bc666469 --- /dev/null +++ b/tests/testthat/test-member-s7.R @@ -0,0 +1,447 @@ +s7_fixture <- function(lines, snapshots = list(), point = NULL, language = "r") { + uri <- if (language == "r") "file:///s7-members.R" else "file:///s7-members.qmd" + document <- Document$new(uri, language = language, version = 1L, content = lines) + data <- parse_document(uri, lines, is_rmarkdown = document$is_rmarkdown) + data$version <- 1L + document$update_parse_data(data) + metadata <- collections::dict() + for (package in names(snapshots)) metadata$set(package, member_index_thaw(snapshots[[package]])) + workspace <- list(member_metadata = metadata, get_documentation = function(...) NULL) + if (is.null(point)) point <- list(row = length(lines) - 1L, col = nchar(tail(lines, 1L))) + list(uri = uri, document = document, workspace = workspace, point = point) +} + +s7_items <- function(lines, snapshots = list(), point = NULL, language = "r") { + fixture <- s7_fixture(lines, snapshots, point, language) + member_completion(fixture$uri, fixture$workspace, fixture$document, fixture$point, TRUE, 200L) +} + +s7_labels <- function(...) vapply(s7_items(...), `[[`, character(1L), "label") + +s7_signature <- function(fixture) { + signature_reply(1L, fixture$uri, fixture$workspace, fixture$document, fixture$point)$result +} + +s7_hover <- function(fixture, point = fixture$point) { + hover_reply(1L, fixture$uri, fixture$workspace, fixture$document, point)$result +} + +test_that("S7 properties and constructor signatures follow the user's declarations", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + code <- c("library(S7)", + "Dog <- new_class(\"Dog\", properties=list(name=class_character, age=class_numeric))", + "lola <- Dog(name=\"Lola\", age=11)") + expect_identical(s7_labels(c(code, "lola@"), list(S7 = snapshot)), c("age", "name")) + expect_identical(s7_labels(c(code, "lola@ag"), list(S7 = snapshot)), "age") + expect_length(s7_labels(c(code, "lola$"), list(S7 = snapshot)), 0L) + fixture <- s7_fixture(c(code, "lola@age"), list(S7 = snapshot)) + expect_identical(s7_hover(fixture)$contents, "```r\n11\n```") + fixture <- s7_fixture(c(code, "Dog()@age"), list(S7 = snapshot)) + expect_identical(s7_hover(fixture)$contents, "```r\ndouble | integer\n```") + expected <- "Dog(name = character(0), age = integer(0))" + fixture <- s7_fixture(c(code, "Dog(age = "), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, expected) + expect_identical(s7_signature(fixture)$activeParameter, 1L) + args <- member_constructor_arguments(fixture$uri, fixture$workspace, fixture$document, fixture$point, "") + expect_identical(vapply(args, `[[`, character(1L), "label"), c("name", "age")) + expect_identical(args[[2L]]$insertText, "age = ") + fixture <- s7_fixture(c(code, "Dog"), list(S7 = snapshot)) + expect_identical(s7_hover(fixture)$contents, sprintf("```r\n%s\n```", expected)) + expect_identical(s7_hover(fixture)$range$start$character, 0L) + fixture <- s7_fixture(c(code, "Alias <- Dog", "Alias("), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, sub("Dog", "Alias", expected)) + fixture <- s7_fixture(c(code, "Dog@constructor("), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, sub("Dog", "constructor", expected)) + expected_slots <- if (isTRUE(snapshot$s7_capabilities$class_ref)) c("age", "name") else character() + expect_identical(s7_labels(c(code, "Dog@constructor()@"), list(S7 = snapshot)), expected_slots) +}) + +test_that("S7 inheritance, nested properties, defaults and unions remain static", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + code <- c("library(S7)", + "Leaf <- new_class(\"Leaf\", properties=list(value=class_numeric))", + "Box <- new_class(\"Box\", properties=list(leaf=Leaf, items=class_list))", + "Child <- new_class(\"Child\", parent=Box, properties=list(label=class_character))") + expect_identical(s7_labels(c(code, "Child()@"), list(S7 = snapshot)), c("items", "label", "leaf")) + expect_identical(s7_labels(c(code, "Child()@leaf@"), list(S7 = snapshot)), "value") + expect_identical(s7_labels(c(code, "Box(items=list(alpha=1))@items$"), list(S7 = snapshot)), "alpha") + expect_identical(s7_labels(c(code, "alias <- Child", "factory <- function() alias()", "factory()@leaf@"), list(S7 = snapshot)), "value") + fixture <- s7_fixture(c(code, "Child("), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "Child(leaf = Leaf(), items = list(), label = character(0))") + code <- c(code, + "Other <- new_class(\"Other\", properties=list(value=class_numeric, extra=class_character))", + "UnionBox <- new_class(\"UnionBox\", properties=list(item=new_union(Leaf, Other)))", + "Defaults <- new_class(\"Defaults\", properties=list(items=new_property(class_list, default=quote(list(alpha=1)))))") + expect_identical(s7_labels(c(code, "UnionBox()@item@"), list(S7 = snapshot)), "value") + expect_identical(s7_labels(c(code, "Defaults()@items$"), list(S7 = snapshot)), "alpha") + expect_identical(s7_labels(c(code, "S7::prop(Child(), \"leaf\")@"), list(S7 = snapshot)), "value") + expect_identical(s7_labels(c(code, "S7::set_props(Box(), items=list(beta=2))@items$"), list(S7 = snapshot)), "beta") + expect_identical(s7_labels(c("library(S7)", "Named <- new_class(\"Named\", constructor=NULL, properties=list(new_property(class_numeric, name=\"value\")))", "Named()@"), list(S7 = snapshot)), "value") + fixture <- s7_fixture(c("library(S7)", "Empty <- new_class(\"Empty\", properties=list())", "Empty("), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "Empty()") +}) + +test_that("S7 custom constructors and function properties use syntax without executing callbacks", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + marker <- withr::local_tempfile() + code <- c("library(S7)", + "Runner <- new_class(\"Runner\", properties=list(run=class_function, items=class_list),", + "constructor=function(first, option=TRUE) new_object(S7_object(),", + "run=function(value, flag=FALSE) value, items=list(done=first)))", + "x <- Runner(unresolved)") + fixture <- s7_fixture(c(code, "Runner("), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "Runner(first, option = TRUE)") + fixture <- s7_fixture(c(code, "x@run(flag = "), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "run(value, flag = FALSE)") + expect_identical(s7_hover(fixture, list(row = 5L, col = 4L))$contents, "```r\nrun(value, flag = FALSE)\n```") + expect_identical(s7_labels(c(code, "x@items$"), list(S7 = snapshot)), "done") + code <- c("library(S7)", sprintf( + "Safe <- new_class(\"Safe\", properties=list(value=new_property(class_numeric, getter=function(self) {writeLines(\"getter\", %s); stop(\"getter\")}), writable=new_property(class_numeric, setter=function(self,value) stop(\"setter\"))), constructor=function(x=1) {stop(\"constructor\"); new_object(S7_object())}, validator=function(self) stop(\"validator\"))", + encodeString(marker, quote = "\""))) + expect_identical(s7_labels(c(code, "Safe(stop(\"argument\"))@"), list(S7 = snapshot)), c("value", "writable")) + fixture <- s7_fixture(c(code, "Safe()@value"), list(S7 = snapshot)) + expect_identical(s7_hover(fixture)$contents, "```r\ndouble | integer\n```") + expect_false(file.exists(marker)) + fixture <- s7_fixture(c("library(S7)", "ReadOnly <- new_class(\"ReadOnly\", properties=list(value=new_property(class_numeric, getter=function(self) 1)))", "ReadOnly("), list(S7 = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "ReadOnly()") +}) + +test_that("S7 recovery supports multiline and quoted properties and stays conservative", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + code <- c("Widget <- S7::new_class(\"Widget\", properties=list(`a b`=S7::class_numeric, beta=S7::class_character))") + items <- s7_items(c(code, "x <- Widget()", "x@", " `a"), list(S7 = snapshot)) + expect_identical(items[[1L]]$textEdit$newText, "`a b`") + expect_identical(items[[1L]]$textEdit$range$start$character, 2L) + expect_identical(s7_labels(c("bad <- )", code, "Widget()@be"), list(S7 = snapshot)), "beta") + expect_length(s7_labels(c(code, "# Widget()@"), list(S7 = snapshot)), 0L) + expect_length(s7_labels(c(code, "Widget <- function(...) unknown", "Widget()@"), list(S7 = snapshot)), 0L) + expect_length(s7_labels(c("new_class <- function(...) unknown", "Widget <- new_class(\"Widget\", properties=list(beta=S7::class_character))", "Widget()@"), list(S7 = snapshot)), 0L) + expect_length(s7_labels(c("Widget <- S7::new_class(\"Widget\", properties=unknown)", "Widget()@"), list(S7 = snapshot)), 0L) + expect_length(s7_labels(c("Widget <- S7::new_class(\"Widget\", parent=unknown)", "Widget()@"), list(S7 = snapshot)), 0L) + expect_length(s7_labels(c("Widget <- S7::new_class(\"Widget\", abstract=TRUE)", "Widget()@"), list(S7 = snapshot)), 0L) + fixture <- s7_fixture(c("library(S7)", "Widget <- new_class(\"Widget\", properties=list(beta=class_character))", "f <- function(Widget) Widget("), list(S7 = snapshot)) + expect_null(member_constructor_symbol(fixture$uri, fixture$workspace, fixture$document, + member_call_location(fixture$document, fixture$point, symbols = TRUE))) + expect_identical(s7_labels(c("```{r}", code, "Widget()@", "```"), list(S7 = snapshot), + point = list(row = 2L, col = 9L), language = "quarto"), c("a b", "beta")) + expect_length(s7_labels(c("```{r}", code, "```", "```{python}", "Widget()@", "```"), list(S7 = snapshot), + point = list(row = 4L, col = 9L), language = "quarto"), 0L) +}) + +test_that("Installed S7 metadata supplies current properties and constructor formals", { + skip_if_not_installed("S7") + marker <- withr::local_tempfile() + scope <- new.env(parent = asNamespace("S7")) + scope$Widget <- S7::new_class("Widget", properties = list(size = S7::class_numeric), + constructor = function(value = 1, flag = TRUE) { + writeLines("ran", marker) + stop("constructor") + S7::new_object(S7::S7_object()) + }) + scope$api <- new.env(parent = emptyenv()) + scope$api$Widget <- scope$Widget + snapshot <- member_index_freeze(member_package_index(member_namespace_input(scope, package = "s7fixture", exports = c("Widget", "api")))) + expect_identical(s7_labels("s7fixture::Widget()@", list(s7fixture = snapshot)), "size") + expect_identical(s7_labels("s7fixture::api$Widget()@", list(s7fixture = snapshot)), "size") + fixture <- s7_fixture("s7fixture::Widget(", list(s7fixture = snapshot)) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "Widget(value = 1, flag = TRUE)") + expect_identical(s7_hover(fixture, list(row = 0L, col = 14L))$contents, "```r\nWidget(value = 1, flag = TRUE)\n```") + scope$Widget <- S7::new_class("Widget", properties = list(changed = S7::class_character)) + changed <- member_index_freeze(member_package_index(member_namespace_input(scope, package = "s7fixture", exports = "Widget"))) + expect_identical(s7_labels("s7fixture::Widget()@", list(s7fixture = changed)), "changed") + expect_false(file.exists(marker)) +}) + +test_that("S7 constructor and property providers work on first requests after edits", { + skip_on_cran() + skip_if_not_installed("S7") + client <- language_client() + path <- withr::local_tempfile(fileext = ".R") + 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")) + # Namespace preparation is asynchronous; wait for it before edit regressions. + expected <- "Dog(name = character(0), age = integer(0))" + ready <- respond_signature(client, path, c(2L, 12L), + retry_when = function(result) !identical(result$signatures[[1L]]$label, expected)) + expect_identical(ready$signatures[[1L]]$label, expected) + notify(client, "workspace/didChangeConfiguration", list(settings = list(parse_delay = 0.5))) + edit <- function(line, version) { + notify(client, "textDocument/didChange", list(textDocument = list(uri = uri, version = version), + contentChanges = list(list(text = paste(c(code, line), collapse = "\n"))))) + } + edit("lola@", 2L) + result <- respond_completion(client, path, c(3L, 5L), retry = FALSE) + expect_setequal(vapply(result$items, `[[`, character(1L), "label"), c("age", "name")) + edit("Dog(ag", 3L) + result <- respond_completion(client, path, c(3L, 6L), retry = FALSE) + args <- Filter(function(item) identical(item$insertText, "age = "), result$items) + expect_length(args, 1L) + edit("Dog(age = ", 4L) + expect_identical(respond_signature(client, path, c(3L, 10L), retry = FALSE)$signatures[[1L]]$label, "Dog(name = character(0), age = integer(0))") + edit("Dog", 5L) + expect_identical(respond_hover(client, path, c(3L, 1L), retry = FALSE)$contents[[1L]], "```r\nDog(name = character(0), age = integer(0))\n```") + edit("lola@age", 6L) + expect_identical(respond_hover(client, path, c(3L, 6L), retry = FALSE)$contents[[1L]], "```r\n11\n```") +}) + +test_that("S7 installed instances and nested records preserve stored members safely", { + skip_if_not_installed("S7") + scope <- new.env(parent = asNamespace("S7")) + scope$Dog <- S7::new_class("Dog", properties = list(age = S7::class_numeric, + run = S7::class_function, items = S7::class_list)) + scope$lola <- scope$Dog(age = 11, run = function(value, flag = FALSE) value, items = list(alpha = 1)) + scope$api <- new.env(parent = emptyenv()) + scope$api$dogs <- list(lola = scope$lola) + snapshot <- member_index_freeze(member_package_index(member_namespace_input(scope, + package = "s7fixture", exports = c("Dog", "lola", "api")))) + metadata <- list(s7fixture = snapshot) + for (path in c("s7fixture::lola", "s7fixture::api$dogs$lola")) { + expect_identical(s7_labels(paste0(path, "@"), metadata), c("age", "items", "run")) + expect_identical(s7_labels(paste0(path, "@items$"), metadata), "alpha") + fixture <- s7_fixture(paste0(path, "@run("), metadata) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "run(value, flag = FALSE)") + expect_identical(s7_hover(s7_fixture(paste0(path, "@age"), metadata))$contents, "```r\n11\n```") + } + marker <- withr::local_tempfile() + ref <- new.env(parent = emptyenv()) + class(ref) <- "S7_class_ref" + makeActiveBinding("class", function() { + writeLines("ran", marker) + scope$Dog + }, ref) + fake <- structure(list(), class = "S7_object", `_S7_class` = ref) + expect_null(member_s7_instance_descriptor(fake)) + expect_false(file.exists(marker)) + # Legacy objects remain recognizable even with a newer installed S7. + legacy <- structure(list(), class = "S7_object", S7_class = scope$Dog) + expect_identical(member_s7_instance_descriptor(legacy)$name, "Dog") +}) + +test_that("S7 generated constructor signatures and matching follow installed rules", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + metadata <- list(S7 = snapshot) + code <- c("library(S7)", + "Parent <- new_class(\"Parent\", properties=list(payload=class_list), constructor=function(seed=1L, mode=\"raw\") new_object(S7_object(), payload=list(seed=seed)))", + "Child <- new_class(\"Child\", parent=Parent, properties=list(label=class_character))") + scope <- new.env(parent = asNamespace("S7")) + eval(parse(text = code[-1L]), scope) + expected <- get_signature("Child", member_s7_function(formals(scope$Child))) + fixture <- s7_fixture(c(code, "Child("), metadata) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, expected) + expect_identical(s7_hover(s7_fixture(c(code, "Child"), metadata))$contents, + sprintf("```r\n%s\n```", expected)) + args <- member_constructor_arguments(fixture$uri, fixture$workspace, fixture$document, fixture$point, "") + expect_false("..." %in% vapply(args, `[[`, character(1L), "label")) + expect_identical(s7_labels(c(code, "Child(3L, label=\"child\")@payload$"), metadata), "seed") + if (isTRUE(snapshot$s7_capabilities$forward)) { + expect_null(s7_hover(s7_fixture(c(code, "Child(3L, \"mode\", \"invalid\")@label"), metadata))) + # No partial or positional matching of a child formal after dots. + hover <- s7_hover(s7_fixture(c(code, "Child(3L, label=\"child\")@label"), metadata)) + expect_identical(hover$contents, "```r\n\"child\"\n```") + expect_null(s7_hover(s7_fixture(c(code, "Child(lab=\"child\")@label"), metadata))) + } + overrides <- c("library(S7)", + "Base <- new_class(\"Base\", properties=list(x=new_property(class_numeric, default=1)))", + "Narrow <- new_class(\"Narrow\", parent=Base, properties=list(x=new_property(class_numeric, default=2)))") + eval(parse(text = overrides[-1L]), scope) + expected <- get_signature("Narrow", member_s7_function(formals(scope$Narrow))) + expect_identical(s7_signature(s7_fixture(c(overrides, "Narrow("), metadata))$signatures[[1L]]$label, expected) + expect_identical(s7_hover(s7_fixture(c(overrides, "Narrow()@x"), metadata))$contents, + sprintf("```r\n%s\n```", scope$Narrow()@x)) + environment_parent <- c("library(S7)", "Env <- new_class(\"Env\", parent=class_environment, properties=list(age=class_numeric))") + if (isTRUE(snapshot$s7_capabilities$class_ref)) { + eval(parse(text = environment_parent[-1L]), scope) + expect_identical(s7_signature(s7_fixture(c(environment_parent, "Env("), metadata))$signatures[[1L]]$label, + get_signature("Env", member_s7_function(formals(scope$Env)))) + } +}) + +test_that("S7 property updates match named object parameters and invalidate unknown writes", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + metadata <- list(S7 = snapshot) + code <- c("library(S7)", + "Box <- new_class(\"Box\", properties=list(items=new_property(class_list, default=quote(list(old=1)))))") + object <- snapshot$s7_capabilities$object + update <- sprintf("S7::set_props(items=list(new=2), `%s`=Box(), .check=FALSE)@items$", object) + expect_identical(s7_labels(c(code, update), metadata), "new") + if (isTRUE(snapshot$s7_capabilities$lists)) { + expect_identical(s7_labels(c(code, "set_props(Box(), list(items=list(new=2)))@items$"), metadata), "new") + expect_length(s7_labels(c(code, "set_props(Box(), unknown)@items$"), metadata), 0L) + custom <- c("library(S7)", + "Box <- new_class(\"Box\", properties=list(items=class_list), constructor=function() new_object(S7_object(), list(items=list(alpha=1))))") + expect_identical(s7_labels(c(custom, "Box()@items$"), metadata), "alpha") + } else { + expect_length(s7_labels(c(code, "set_props(Box(), list(items=list(new=2)))@items$"), metadata), 0L) + } +}) + +test_that("S7 named bindings are verified and recovered in document and function scopes", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + skip_if_not(isTRUE(snapshot$s7_capabilities$bind)) + metadata <- list(S7 = snapshot) + code <- c("library(S7)", "Dog := new_class(properties=list(age=class_numeric))") + expect_identical(s7_labels(c(code, "Dog()@"), metadata), "age") + expect_identical(s7_signature(s7_fixture(c(code, "Dog("), metadata))$signatures[[1L]]$label, + "Dog(age = integer(0))") + expect_identical(s7_hover(s7_fixture(c(code, "Dog"), metadata))$contents, + "```r\nDog(age = integer(0))\n```") + expect_identical(s7_labels(c("library(S7)", "factory <- function() {", code[[2L]], "Dog()", "}", "factory()@"), metadata), "age") + expect_identical(s7_labels(c("library(S7)", "f <- function() {", code[[2L]], "Dog()@", "}"), metadata, + point = list(row = 3L, col = 6L)), "age") + shadowed <- c("library(S7)", "`:=` <- function(lhs, rhs) NULL", code[[2L]], "Dog()@") + expect_length(s7_labels(shadowed, metadata), 0L) + expect_identical(s7_labels(c(code, "Dog := new_class(name=\"Other\", properties=list(wrong=class_numeric))", "Dog()@"), metadata), "age") + expect_length(s7_labels(c("library(S7)", "Dog := unknown()", "Dog()@"), metadata), 0L) +}) + +test_that("S7 external descriptors respect exports, versions and recursion bounds", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + skip_if_not("new_external_class" %in% snapshot$s7_capabilities$exports) + scope <- new.env(parent = asNamespace("S7")) + scope$Dog <- S7::new_class("Dog", properties = list(age = S7::class_numeric)) + scope$Hidden <- scope$Dog + dep <- member_index_freeze(member_package_index(member_namespace_input(scope, + package = "s7fixture", exports = "Dog"))) + dep$identity <- list(version = "1.0.0") + metadata <- list(S7 = snapshot, s7fixture = dep) + code <- c("library(S7)", "Wrapped <- new_class(\"Wrapped\", properties=list(child=new_external_class(\"s7fixture\", \"Dog\")))") + expect_identical(s7_labels(c(code, "Wrapped()@child@"), metadata), "age") + expected <- "Wrapped(child = (S7::as_class(s7fixture::Dog))())" + expect_identical(s7_signature(s7_fixture(c(code, "Wrapped("), metadata))$signatures[[1L]]$label, expected) + for (spec in c("new_external_class(\"s7fixture\", \"Hidden\")", + "new_external_class(\"missingpkg\", \"Dog\")", "new_external_class(\"s7fixture\", \"Dog\", version=\"2.0.0\")")) { + source <- c("library(S7)", paste0("Wrapped <- new_class(\"Wrapped\", properties=list(child=", spec, "))"), "Wrapped()@child@") + expect_length(s7_labels(source, metadata), 0L) + } + code <- c("library(S7)", "Child <- new_class(\"Child\", parent=s7fixture::Dog, package=\"consumer\", properties=list(label=class_character))") + expect_identical(s7_signature(s7_fixture(c(code, "Child("), metadata))$signatures[[1L]]$label, + "Child(..., label = character(0))") + expect_identical(s7_labels(c(code, "Child()@"), metadata), c("age", "label")) + cyclic <- member_index_thaw(dep) + cyclic$package_roots$Loop <- member_s7_value(s7_descriptor = list(kind = "external", package = "s7fixture", name = "Loop")) + budget <- new.env(parent = emptyenv()) + expect_null(member_s7_external(cyclic$package_roots$Loop$s7_descriptor, cyclic, list(), budget)) +}) + +test_that("S7 S4 parents, S3 defaults and deprecation declarations retain descriptors", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + metadata <- list(S7 = snapshot) + if (isTRUE(snapshot$s7_capabilities$s4)) { + code <- c("library(S7)", "Base <- methods::setClass(\"S7CompatBase\", slots=c(value=\"numeric\"))", + "Hybrid <- new_class(\"Hybrid\", parent=Base, properties=list(label=class_character))") + expect_identical(s7_labels(c(code, "Hybrid()@"), metadata), c("label", "value")) + expect_identical(s7_signature(s7_fixture(c(code, "Hybrid("), metadata))$signatures[[1L]]$label, + "Hybrid(value = integer(0), label = character(0))") + scope <- new.env(parent = globalenv()) + scope$new_class <- S7::new_class + scope$class_character <- S7::class_character + scope$Base <- methods::setClass("S7CompatBase", slots = c(value = "numeric"), where = scope) + eval(parse(text = code[[3L]]), scope) + withr::defer(methods::removeClass("S7CompatBase", where = globalenv())) + withr::defer(methods::removeClass("Hybrid", where = globalenv())) + scope$hybrid <- scope$Hybrid(value = 1, label = "hybrid") + installed <- member_index_freeze(member_package_index(member_namespace_input(scope, + package = "s7fixture", exports = c("Hybrid", "hybrid")))) + expect_identical(s7_labels("s7fixture::hybrid@", list(s7fixture = installed)), c("label", "value")) + } + code <- c("library(S7)", "Dates <- new_class(\"Dates\", properties=list(date=class_Date, data=class_data.frame, choice=class_factor))") + scope <- new.env(parent = asNamespace("S7")) + eval(parse(text = code[-1L]), scope) + if (isTRUE(snapshot$s7_capabilities$class_ref)) { + expect_identical(s7_signature(s7_fixture(c(code, "Dates("), metadata))$signatures[[1L]]$label, + get_signature("Dates", member_s7_function(formals(scope$Dates)))) + } else { + expect_match(s7_signature(s7_fixture(c(code, "Dates("), metadata))$signatures[[1L]]$label, + ".__unknown_s7_default__", fixed = TRUE) + } + if ("deprecated_class" %in% snapshot$s7_capabilities$exports) { + code <- c("library(S7)", "Basket := deprecated_class(properties=list(size=class_double, deprecated_property(\"count\", new=\"size\", when=\"1.0.0\")), when=\"2.0.0\")") + expect_identical(s7_labels(c(code, "Basket()@"), metadata), c("count", "size")) + expect_identical(s7_hover(s7_fixture(c(code, "Basket(size=3)@count"), metadata))$contents, "```r\n3\n```") + expect_identical(s7_signature(s7_fixture(c(code, "Basket("), metadata))$signatures[[1L]]$label, + "Basket(size = numeric(0), count = size)") + } +}) + +test_that("S7 union syntax and same-package external properties remain bounded", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + metadata <- list(S7 = snapshot) + code <- c("library(S7)", "Leaf <- new_class(\"Leaf\", properties=list(value=class_numeric))", + "Box <- new_class(\"Box\", properties=list(item=Leaf | NULL))") + expect_identical(s7_labels(c(code, "Box()@item@"), metadata), character()) + fixture <- s7_fixture(c(code, "Box("), metadata) + expect_identical(s7_signature(fixture)$signatures[[1L]]$label, "Box(item = Leaf())") + shadowed <- c(code[1:2], "`|` <- function(x, y) unknown", code[[3L]], "Box()@item@") + expect_length(s7_labels(shadowed, metadata), 0L) + if ("new_external_class" %in% snapshot$s7_capabilities$exports) { + scope <- new.env(parent = asNamespace("S7")) + scope$Hidden <- S7::new_class("Hidden", properties = list(age = S7::class_numeric)) + scope$Box <- S7::new_class("Box", package = "s7fixture", properties = list( + child = S7::new_external_class("s7fixture", "Hidden"))) + dep <- member_index_freeze(member_package_index(member_namespace_input(scope, + package = "s7fixture", exports = "Box"))) + expect_identical(s7_labels("s7fixture::Box()@child@", list(s7fixture = dep)), "age") + recursive <- c("library(S7)", "Tree <- new_class(\"Tree\", package=\"localpkg\", properties=list(child=new_external_class(\"localpkg\", \"Tree\")))") + expect_identical(s7_labels(c(recursive, "Tree()@child@"), metadata), "child") + } +}) + +test_that("S7 workers snapshot loaded external dependencies without constructor calls", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + skip_if_not("new_external_class" %in% snapshot$s7_capabilities$exports) + ns <- new.env(parent = asNamespace("S7")) + info <- new.env(parent = emptyenv()) + info$spec <- c(name = "s7compatdep", version = "1.0.0") + info$exports <- new.env(parent = emptyenv()) + ns[[".__NAMESPACE__."]] <- info + internal <- get(".Internal", baseenv()) + internal(registerNamespace("s7compatdep", ns)) + withr::defer(internal(unregisterNamespace("s7compatdep"))) + marker <- withr::local_tempfile() + ns$Dog <- S7::new_class("Dog", properties = list(age = S7::class_numeric), + constructor = function(age = 11) { + writeLines("ran", marker) + stop("constructor") + S7::new_object(S7::S7_object()) + }) + info$exports$Dog <- "Dog" + consumer <- new.env(parent = asNamespace("S7")) + consumer$Wrapped <- S7::new_class("Wrapped", properties = list( + child = S7::new_external_class("s7compatdep", "Dog"))) + metadata <- member_index_freeze(member_package_index(member_namespace_input(consumer, + package = "s7consumer", exports = "Wrapped"))) + expect_identical(metadata$s7_dependencies$s7compatdep$identity$version, "1.0.0") + expect_identical(s7_labels("s7consumer::Wrapped()@child@", list(s7consumer = metadata)), "age") + expect_false(file.exists(marker)) +}) + +test_that("S7 new_object keeps statically known parent properties", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + code <- c("library(S7)", + "Parent <- new_class(\"Parent\", properties=list(items=class_list))", + "Child <- new_class(\"Child\", parent=Parent, properties=list(label=class_character), constructor=function() new_object(Parent(items=list(alpha=1)), label=\"child\"))") + expect_identical(s7_labels(c(code, "Child()@items$"), list(S7 = snapshot)), "alpha") +}) + + +test_that("S7 setters never retain a stale default member shape", { + skip_if_not_installed("S7") + snapshot <- member_prepare_package("S7") + code <- c("library(S7)", + "Box <- new_class(\"Box\", properties=list(items=new_property(class_list, default=quote(list(old=1)), setter=function(self, value) stop(\"setter\"))))") + expect_length(s7_labels(c(code, "Box()@items$"), list(S7 = snapshot)), 0L) + expect_length(s7_labels(c(code, "set_props(Box(), items=list(new=2))@items$"), list(S7 = snapshot)), 0L) +})