diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4e480d4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +# Compiled object code +src/*.o +src/*.so +src/*.dll +src/*.dylib +src/symbols.rds + +# R CMD build / check artifacts +*.tar.gz +*.Rcheck/ + +# Editor / IDE +.Rproj.user/ +.Rhistory +.RData +.Ruserdata diff --git a/Makefile b/Makefile index ed02a41..8a9fa4b 100644 --- a/Makefile +++ b/Makefile @@ -1,13 +1,32 @@ R = R RSCRIPT = Rscript -.PHONY: install test clean +# Library holding the corpus packages installed WITH srcref retention, used by +# the FULL_TEST whole-package tests. Prepended to .libPaths() for `test-full` +# and `corpus-install`. Override with: make test-full CORPUS_LIB=/path/to/lib +CORPUS_LIB ?= $(HOME)/Rlib_test + +# Packages exercised by the corpus tests (must be installed with srcref). +CORPUS_PKGS = 'data.table','dplyr','fs','ggplot2','glue','jsonlite','stringr','zoo' + +.PHONY: install test test-full corpus-install clean install: $(R) CMD INSTALL . +# Fast suite: blacklist + snapshot tests. Corpus tests skip (no FULL_TEST). test: $(RSCRIPT) -e "testthat::test_dir('tests/testthat', load_package = 'source')" +# Full suite including the slow whole-package corpus tests. Requires the corpus +# installed with srcref retention (run `make corpus-install` once first). +test-full: + FULL_TEST=1 $(RSCRIPT) -e ".libPaths(c('$(CORPUS_LIB)', .libPaths())); testthat::test_dir('tests/testthat', load_package = 'source')" + +# Install the corpus packages from source with srcref retained into CORPUS_LIB. +corpus-install: + mkdir -p "$(CORPUS_LIB)" + $(RSCRIPT) -e ".libPaths(c('$(CORPUS_LIB)', .libPaths())); install.packages(c($(CORPUS_PKGS)), lib='$(CORPUS_LIB)', INSTALL_opts='--with-keep.source', type='source', dependencies=c('Depends','Imports','LinkingTo'))" + clean: rm -rf *.tar.gz *.Rcheck diff --git a/NAMESPACE b/NAMESPACE index 1c3dba2..153b679 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,3 +6,4 @@ export(impute_srcrefs) export(reset_impute_blacklist) export(set_impute_blacklist) export(source_impute_srcrefs) +useDynLib(imputesrcref, .registration = TRUE) diff --git a/R/blacklist_api.R b/R/blacklist_api.R index 40869da..52b30fa 100644 --- a/R/blacklist_api.R +++ b/R/blacklist_api.R @@ -1,102 +1,44 @@ -blacklist_option_name <- "imputesrcref.wrap_arg_blacklist" - -specialsxp_builtin_names <- local({ - nms <- builtins() - out <- nms[vapply(nms, function(nm) { - obj <- get(nm, envir = baseenv(), inherits = FALSE) - is.primitive(obj) && identical(typeof(obj), "special") - }, logical(1))] - sort(unique(out)) -}) - -normalize_blacklist_names <- function(functions, arg = "functions") { - if (is.null(functions)) { - return(character()) - } - if (!is.character(functions)) { - stop(sprintf("`%s` must be NULL or a character vector", arg), call. = FALSE) - } - - out <- trimws(functions) - out <- out[!is.na(out) & nzchar(out)] - sort(unique(out)) -} - -user_blacklist_names <- function() { - normalize_blacklist_names(getOption(blacklist_option_name, NULL), arg = blacklist_option_name) -} - -# rlang NSE functions that capture their argument as an unevaluated expression -# rather than evaluating it. Wrapping their arguments in transparent braces -# changes what expression is captured, breaking downstream DSL evaluators such -# as tidyselect (e.g. `expr({c(x)})` captures `{c(x)}` instead of `c(x)` and -# `tidyselect::eval_select` then fails to resolve the column `x`). -rlang_nse_names <- c( - "expr", "quo", "quos", - "enquo", "enquos", "enexpr", "enexprs" -) - -effective_blacklist_names <- function() { - sort(unique(c(specialsxp_builtin_names, rlang_nse_names, user_blacklist_names()))) -} - -#' Get call names blacklisted from generic argument wrapping. +#' Manage call blacklist for generic argument wrapping #' #' By default, [impute_srcrefs()] skips argument wrapping for primitive -#' `SPECIALSXP` calls discovered from [builtins()]. This getter can return only -#' user-configured entries, or the effective blacklist including defaults. +#' `SPECIALSXP` calls discovered from [builtins()]. These functions inspect and +#' modify the user-configured portion of that blacklist. +#' +#' - `get_impute_blacklist()` returns the blacklist, optionally including the +#' built-in defaults. +#' - `set_impute_blacklist()` adds or replaces user entries, stored in +#' `options(imputesrcref.wrap_arg_blacklist = ...)`. +#' - `reset_impute_blacklist()` clears user entries. #' #' @param include_default If `TRUE`, include built-in `SPECIALSXP` names. +#' @param functions Character vector of call names. `NULL` clears user entries. +#' @param append If `TRUE` append to existing user entries; otherwise replace. #' -#' @return A sorted unique character vector of call names. +#' @return +#' `get_impute_blacklist()` returns a sorted unique character vector of call +#' names. `set_impute_blacklist()` invisibly returns the current +#' user-configured entries. `reset_impute_blacklist()` invisibly returns an +#' empty character vector. #' #' @examples #' head(get_impute_blacklist()) #' set_impute_blacklist(c("str_c", "paste")) #' get_impute_blacklist(include_default = FALSE) #' reset_impute_blacklist() +#' @rdname impute_blacklist #' @export get_impute_blacklist <- function(include_default = TRUE) { - if (!is.logical(include_default) || length(include_default) != 1L || is.na(include_default)) { - stop("`include_default` must be TRUE or FALSE", call. = FALSE) - } - - if (isTRUE(include_default)) { - return(effective_blacklist_names()) - } - - user_blacklist_names() + .Call(C_get_impute_blacklist, include_default) } -#' Set user call names blacklisted from generic argument wrapping. -#' -#' User entries are stored in `options(imputesrcref.wrap_arg_blacklist = ...)`. -#' -#' @param functions Character vector of call names. `NULL` clears user entries. -#' @param append If `TRUE` append to existing user entries; otherwise replace. -#' -#' @return Invisibly returns current user-configured blacklist entries. +#' @rdname impute_blacklist #' @export set_impute_blacklist <- function(functions, append = TRUE) { - if (!is.logical(append) || length(append) != 1L || is.na(append)) { - stop("`append` must be TRUE or FALSE", call. = FALSE) - } - - incoming <- normalize_blacklist_names(functions, arg = "functions") - current <- if (isTRUE(append)) user_blacklist_names() else character() - next_values <- sort(unique(c(current, incoming))) - - options(imputesrcref.wrap_arg_blacklist = next_values) - invisible(next_values) + invisible(.Call(C_set_impute_blacklist, functions, append)) } -#' Reset user call names blacklisted from generic argument wrapping. -#' -#' Clears user entries configured via [set_impute_blacklist()]. -#' -#' @return Invisibly returns an empty character vector. +#' @rdname impute_blacklist #' @export reset_impute_blacklist <- function() { - options(imputesrcref.wrap_arg_blacklist = NULL) - invisible(character()) + invisible(.Call(C_reset_impute_blacklist)) } diff --git a/R/impute_srcrefs.R b/R/impute_srcrefs.R index 61304e0..f7dd79b 100644 --- a/R/impute_srcrefs.R +++ b/R/impute_srcrefs.R @@ -1,573 +1,3 @@ -is_call_named <- function(expr, name) { - is.call(expr) && is.symbol(expr[[1]]) && identical(as.character(expr[[1]]), name) -} - -is_braced <- function(expr) { - is_call_named(expr, "{") -} - -is_missing_arg <- function(x) { - is.symbol(x) && identical(as.character(x), "") -} - -is_logical_op_call <- function(expr) { - is.call(expr) && - is.symbol(expr[[1]]) && - as.character(expr[[1]]) %in% c("&&", "||", "&", "|") -} - -is_unquote_call <- function(expr) { - # rlang's !! and !!! unquoting operators appear in the R AST as double/triple - # negation: !!x -> !(!(x)), !!!x -> !(!(!(x))). Wrapping them in transparent - # braces changes semantics when the surrounding call is later processed by - # rlang::inject() or similar, because {!!x} injects a block instead of the - # bare value that !! would produce. - # The parenthesized form (!!x) parses to `(`(!(!(x))): the outer call is `(` - # not `!`, so we recurse into the `(` argument to check for the double-neg. - if (!is.call(expr) || length(expr) != 2L) { - return(FALSE) - } - head <- expr[[1L]] - if (identical(head, as.name("!"))) { - inner <- expr[[2L]] - return( - is.call(inner) && - length(inner) == 2L && - identical(inner[[1L]], as.name("!")) - ) - } - if (identical(head, as.name("("))) { - return(is_unquote_call(expr[[2L]])) - } - FALSE -} - -is_unary_arith_call <- function(expr) { - # Unary - and + must not be brace-wrapped as generic call arguments. - # In DSL contexts (tidyselect, dplyr) -f() is a structural "deselect f()" - # operator: wrapping to {-f()} causes the block to evaluate to a negative - # integer, which DSL validators reject ("Selections can't have negative values"). - is.call(expr) && - length(expr) == 2L && - is.symbol(expr[[1L]]) && - as.character(expr[[1L]]) %in% c("-", "+") -} - -visual_col_to_byte_col <- function(line, visual_col) { - # Convert a visual (tab-expanded, 8-wide tab stops) column number to the - # character position in `line` that starts at that visual column. - # R's srcref slots [5] and [6] record visual columns while substr() requires - # character (byte) positions: for tab-indented code these differ. - # Example: `\t function(x)` has visual col 11 for `f` but byte pos 4. - chars <- strsplit(line, "", fixed = TRUE)[[1L]] - vis <- 1L - for (i in seq_along(chars)) { - if (vis >= visual_col) { - return(i) - } - if (chars[[i]] == "\t") { - vis <- ((vis - 1L) %/% 8L + 1L) * 8L + 1L - } else { - vis <- vis + 1L - } - } - length(chars) -} - -expr_children <- function(node_id, ctx) { - # `node_id` is an `expr` row id from parse data. This returns child `expr` - # node ids in source order so AST argument positions can be mapped to parse - # ranges deterministically. - rows <- ctx$expr[ctx$expr$parent == node_id, , drop = FALSE] - if (nrow(rows) == 0L) { - return(integer()) - } - - rows <- rows[order(rows$line1, rows$col1, rows$id), , drop = FALSE] - rows$id -} - -node_srcref <- function(node_id, ctx) { - # Build an srcref from parse-data coordinates for a single expression node. - # The offsets are needed because parsed text can start at a non-1 line/column - # inside the original source file. - row <- ctx$expr_index[[as.character(node_id)]] - if (is.null(row)) { - stop(sprintf("Missing parse node id %s", node_id), call. = FALSE) - } - - line1 <- row$line1 + ctx$line_offset - line2 <- row$line2 + ctx$line_offset - col1 <- row$col1 + if (row$line1 == 1L) ctx$first_col_offset else 0L - col2 <- row$col2 + if (row$line2 == 1L) ctx$first_col_offset else 0L - - sr <- c(line1, col1, line2, col2, col1, col2, line1, line2) - sr <- as.integer(sr) - attr(sr, "srcfile") <- ctx$srcfile - class(sr) <- "srcref" - sr -} - -wrap_with_transparent_brace <- function(expr, sr) { - # Transparent wrapper: both srcref entries point to the wrapped expression - # span, making injected braces source-invisible for mapping purposes. - out <- call("{", expr) - attr(out, "srcref") <- list(sr, sr) - out -} - -source_text_from_srcref <- function(fn) { - sr <- attr(fn, "srcref", exact = TRUE) - - # Fallback for functions that do not carry srcref metadata. - if (is.null(sr)) { - if (!isTRUE(getOption("imputesrcref.allow_deparse_fallback", FALSE))) { - message( - paste( - "Function has no srcref metadata and deparse fallback is disabled; no changes were made.", - "Set options(imputesrcref.allow_deparse_fallback = TRUE)", - "to enable deparse-based fallback." - ) - ) - return(NULL) - } - - txt <- paste(deparse(fn, width.cutoff = 500L), collapse = "\n") - return(list( - text = txt, - srcfile = srcfilecopy("", txt), - line_offset = 0L, - first_col_offset = 0L - )) - } - - srcfile <- attr(sr, "srcfile", exact = TRUE) - if (is.null(srcfile)) { - stop("Function srcref is missing srcfile", call. = FALSE) - } - - sr <- as.integer(sr) - - # For installed package functions with preserved parse data, srcref often - # stores parse-table line span in slots 7/8 while slots 1/3 are remapped by - # #line directives. Try parsed span first, then fall back. - candidates <- list( - c(sr[7], sr[8], sr[5], sr[6]), - c(sr[1], sr[3], sr[5], sr[6]), - c(sr[1], sr[3], sr[2], sr[4]) - ) - - chosen <- NULL - lines <- character() - - for (cand in candidates) { - if (length(cand) != 4L || any(is.na(cand)) || any(cand <= 0L)) { - next - } - - start_line <- cand[[1L]] - end_line <- cand[[2L]] - start_col <- cand[[3L]] - end_col <- cand[[4L]] - - if (end_line < start_line) { - next - } - if (end_line == start_line && end_col < start_col) { - next - } - - attempt <- tryCatch( - getSrcLines(srcfile, start_line, end_line), - error = function(e) character() - ) - - if (length(attempt) == 0L) { - next - } - - chosen <- list( - start_line = start_line, - end_line = end_line, - start_col = start_col, - end_col = end_col - ) - lines <- attempt - break - } - - if (is.null(chosen) || length(lines) == 0L) { - stop("Could not read source lines for function", call. = FALSE) - } - - if (length(lines) == 1L) { - byte_sc <- visual_col_to_byte_col(lines[1L], chosen$start_col) - byte_ec <- visual_col_to_byte_col(lines[1L], chosen$end_col) - lines[1L] <- substr(lines[1L], byte_sc, byte_ec) - } else { - byte_sc <- visual_col_to_byte_col(lines[1L], chosen$start_col) - lines[1L] <- substr(lines[1L], byte_sc, nchar(lines[1L])) - byte_ec <- visual_col_to_byte_col(lines[length(lines)], chosen$end_col) - lines[length(lines)] <- substr(lines[length(lines)], 1L, byte_ec) - } - - list( - # `text` is what we parse to obtain getParseData(); offsets map parse - # coordinates back to the original source file coordinates. - text = paste(lines, collapse = "\n"), - srcfile = srcfile, - line_offset = chosen$start_line - 1L, - first_col_offset = chosen$start_col - 1L - ) -} - -map_generic_indices <- function(parts, child_ids, drop_first_child = FALSE) { - ids <- child_ids - if (drop_first_child && length(ids) > 0L) { - ids <- ids[-1L] - } - - n <- length(parts) - present <- which(!vapply(parts, is_missing_arg, logical(1))) - - # Prefer mappings that naturally skip explicit missing arguments. - if (length(ids) == length(present)) { - return(list(indices = present, ids = ids)) - } - if (length(present) >= 1L && length(ids) == length(present) - 1L) { - return(list(indices = present[-1L], ids = ids)) - } - - if (length(ids) == n) { - return(list(indices = seq_len(n), ids = ids)) - } - if (length(ids) == n - 1L && n >= 2L) { - return(list(indices = seq.int(2L, n), ids = ids)) - } - - NULL -} - -node_has_token <- function(node_id, token, ctx) { - any(ctx$pd$parent == node_id & ctx$pd$token == token) -} - -rebuild_call <- function(parts, template) { - out <- as.call(parts) - attrs <- attributes(template) - if (!is.null(attrs)) { - attributes(out) <- attrs - } - out -} - -set_element <- function(x, i, value) { - # Preserve explicit NULL arguments/defaults. `[[<- NULL` deletes an element. - # `[<-` coerces pairlists to regular lists; restore the original type so that - # nested `function(...)` formal lists remain pairlists as R requires. - is_pl <- is.pairlist(x) - x[i] <- list(value) - if (is_pl) as.pairlist(x) else x -} - -transform_expr <- function(expr, node_id, ctx) { - # Core imputation walker. - # - # - `expr`: current language object (AST node). - # - `node_id`: parse-data `expr` id corresponding to `expr`. - # - `ctx`: parse-data context with: - # * `pd`: full parse table. - # * `expr`: parse rows where token == "expr". - # * `expr_index`: fast lookup from expr id -> row. - # * `srcfile`, `line_offset`, `first_col_offset`: srcref reconstruction - # metadata. - # - # The recursion keeps AST and parse tree aligned. Whenever a target slot is - # not already `{ ... }`, we inject a brace call and impute its srcref from the - # corresponding parse-data node. - if (!is.call(expr)) { - return(expr) - } - - if (is_braced(expr) && !node_has_token(node_id, "'{'", ctx)) { - # Already-injected transparent braces may not exist in original parse data. - # Recurse into the child with the same node_id and preserve brace srcref. - parts <- as.list(expr) - sr <- attr(expr, "srcref", exact = TRUE) - - if (length(parts) >= 2L) { - parts <- set_element(parts, 2L, transform_expr(parts[[2L]], node_id, ctx)) - } - - out <- rebuild_call(parts, expr) - if (!is.null(sr)) { - attr(out, "srcref") <- sr - } - return(out) - } - - parts <- as.list(expr) - op <- if (is.symbol(parts[[1]])) as.character(parts[[1]]) else "" - child_ids <- expr_children(node_id, ctx) - - recurse_slot <- function(i, child_id, wrap = FALSE) { - # Helper for "recurse into slot i, then optionally brace-wrap and impute". - value <- transform_expr(parts[[i]], child_id, ctx) - # Do not wrap expressions whose callee is blacklisted (e.g. the ~ formula - # operator is a SPECIALSXP): wrapping `~cyl == 2` to `{~cyl == 2}` changes - # the AST structure, breaking functions that build quosures/formulas using - # `&`/`|` on formula objects and then inspect them with identical(). - slot_expr <- parts[[i]] - slot_callee_blacklisted <- is.call(slot_expr) && - is.symbol(slot_expr[[1L]]) && - as.character(slot_expr[[1L]]) %in% ctx$arg_wrap_blacklist - if (wrap && !is_braced(value) && !slot_callee_blacklisted) { - value <- wrap_with_transparent_brace(value, node_srcref(child_id, ctx)) - } - parts <<- set_element(parts, i, value) - } - - if (identical(op, "function")) { - fmls <- parts[[2]] - fml_text <- as.character(fmls) - cursor <- 1L - - for (idx in seq_along(fml_text)) { - if (identical(fml_text[[idx]], "")) { - next - } - - if (cursor > length(child_ids)) { - stop("Parse mapping mismatch for function formals", call. = FALSE) - } - - cid <- child_ids[[cursor]] - cursor <- cursor + 1L - - val <- fmls[[idx]] - val <- transform_expr(val, cid, ctx) - if (!is_braced(val) && is.call(val)) { - val <- wrap_with_transparent_brace(val, node_srcref(cid, ctx)) - } - fmls <- set_element(fmls, idx, val) - } - - if (cursor > length(child_ids)) { - stop("Parse mapping mismatch for function body", call. = FALSE) - } - - body_id <- child_ids[[cursor]] - body_expr <- transform_expr(parts[[3]], body_id, ctx) - # Only wrap the body if it is not already a call (e.g. a symbol or literal). - # Wrapping a call body in { } changes body(fn)[[1]] from the callee to `{`, - # breaking meta-programming tests that introspect function body structure. - # Call-type bodies already have their sub-expressions tracked individually. - if (!is_braced(body_expr) && !is.call(body_expr)) { - body_expr <- wrap_with_transparent_brace(body_expr, node_srcref(body_id, ctx)) - } - - if (is.null(fmls)) { - # `function()` stores formals as NULL. Preserve that slot explicitly, - # because `parts[[2]] <- NULL` would delete the element. - out <- as.call(list(as.name("function"), NULL, body_expr)) - attrs <- attributes(expr) - if (!is.null(attrs)) { - attributes(out) <- attrs - } - return(out) - } - - parts <- set_element(parts, 2L, fmls) - parts <- set_element(parts, 3L, body_expr) - return(rebuild_call(parts, expr)) - } - - if (identical(op, "if")) { - if (length(child_ids) < 2L) { - # Some package parse tables do not expose expected `if` child expr nodes. - # Fall back to structural recursion without additional brace imputation. - if (length(parts) >= 2L) { - parts <- set_element(parts, 2L, transform_expr(parts[[2L]], node_id, ctx)) - } - if (length(parts) >= 3L) { - parts <- set_element(parts, 3L, transform_expr(parts[[3L]], node_id, ctx)) - } - if (length(parts) >= 4L) { - parts <- set_element(parts, 4L, transform_expr(parts[[4L]], node_id, ctx)) - } - return(rebuild_call(parts, expr)) - } - - cond <- transform_expr(parts[[2L]], child_ids[[1L]], ctx) - if (!is_braced(cond) && !is_logical_op_call(cond)) { - cond <- wrap_with_transparent_brace(cond, node_srcref(child_ids[[1L]], ctx)) - } - parts <- set_element(parts, 2L, cond) - - recurse_slot(3L, child_ids[[2L]], wrap = TRUE) - if (length(parts) >= 4L && length(child_ids) >= 3L) { - recurse_slot(4L, child_ids[[3L]], wrap = TRUE) - } - - return(rebuild_call(parts, expr)) - } - - if (identical(op, "while")) { - if (length(child_ids) < 2L) { - stop("Parse mapping mismatch for while expression", call. = FALSE) - } - - cond <- transform_expr(parts[[2L]], child_ids[[1L]], ctx) - if (!is_braced(cond) && !is_logical_op_call(cond)) { - cond <- wrap_with_transparent_brace(cond, node_srcref(child_ids[[1L]], ctx)) - } - parts <- set_element(parts, 2L, cond) - - recurse_slot(3L, child_ids[[2L]], wrap = TRUE) - return(rebuild_call(parts, expr)) - } - - if (identical(op, "for")) { - # Parse data represents `for (...)` sequence under a dedicated `forcond` - # subtree, so we fetch that expr id explicitly instead of relying only on - # direct child expr ids. - forcond <- ctx$pd[ctx$pd$parent == node_id & ctx$pd$token == "forcond", , drop = FALSE] - seq_id <- integer() - if (nrow(forcond) == 1L) { - seq_rows <- ctx$pd[ctx$pd$parent == forcond$id[[1L]] & ctx$pd$token == "expr", , drop = FALSE] - if (nrow(seq_rows) >= 1L) { - seq_rows <- seq_rows[order(seq_rows$line1, seq_rows$col1, seq_rows$id), , drop = FALSE] - seq_id <- seq_rows$id[[1L]] - } - } - - body_ids <- child_ids - if (length(body_ids) >= 1L && length(seq_id) == 1L && identical(body_ids[[1L]], seq_id)) { - body_ids <- body_ids[-1L] - } - - if (length(seq_id) != 1L || length(body_ids) < 1L) { - stop("Parse mapping mismatch for for expression", call. = FALSE) - } - - recurse_slot(3L, seq_id[[1L]], wrap = TRUE) - recurse_slot(4L, body_ids[[1L]], wrap = TRUE) - return(rebuild_call(parts, expr)) - } - - if (identical(op, "repeat")) { - if (length(child_ids) < 1L) { - stop("Parse mapping mismatch for repeat expression", call. = FALSE) - } - - recurse_slot(2L, child_ids[[1L]], wrap = TRUE) - return(rebuild_call(parts, expr)) - } - - if (identical(op, "switch")) { - ids <- child_ids - if (length(ids) > 0L) { - ids <- ids[-1L] - } - - cursor <- 1L - for (i in seq.int(2L, length(parts))) { - if (is_missing_arg(parts[[i]])) { - next - } - - if (cursor > length(ids)) { - break - } - - cid <- ids[[cursor]] - cursor <- cursor + 1L - - recurse_slot(i, cid, wrap = TRUE) - } - - return(rebuild_call(parts, expr)) - } - - if (op %in% c("&&", "||", "&", "|")) { - if (length(child_ids) < 2L) { - # Some package parse tables do not expose both operand expr nodes. - # Fall back to structural recursion without brace imputation. - if (length(child_ids) == 1L) { - parts <- set_element(parts, 2L, transform_expr(parts[[2L]], child_ids[[1L]], ctx)) - if (length(parts) >= 3L) { - parts <- set_element(parts, 3L, transform_expr(parts[[3L]], node_id, ctx)) - } - } else { - if (length(parts) >= 2L) { - parts <- set_element(parts, 2L, transform_expr(parts[[2L]], node_id, ctx)) - } - if (length(parts) >= 3L) { - parts <- set_element(parts, 3L, transform_expr(parts[[3L]], node_id, ctx)) - } - } - return(rebuild_call(parts, expr)) - } - - recurse_slot(2L, child_ids[[1L]], wrap = TRUE) - recurse_slot(3L, child_ids[[2L]], wrap = TRUE) - return(rebuild_call(parts, expr)) - } - - mapping <- map_generic_indices(parts, child_ids) - if (is.null(mapping)) { - return(expr) - } - - # For plain parenthesized calls, wrap argument slots but never the callee. - # Wrapping is restricted to call expressions to avoid touching simple values - # (e.g. f(x + 1, 1) -> f({x + 1}, 1)). - is_blacklisted <- nzchar(op) && op %in% ctx$arg_wrap_blacklist - wrap_generic_args <- node_has_token(node_id, "'('", ctx) && - !identical(op, "(") && - !is_blacklisted && - isTRUE(ctx$wrap_call_args) - - # Assignment operators: the LHS target (slot 2) must never be brace-wrapped. - # Wrapping `x[i]` in braces makes it `{x[i]} <- value`, which causes R to - # look for the nonexistent `{<-` replacement function. - is_assign_op <- nzchar(op) && op %in% c("<-", "<<-", "=", "->", "->>") - - lhs_slot <- if (op %in% c("->", "->>")) 3L else 2L - - for (k in seq_along(mapping$indices)) { - i <- mapping$indices[[k]] - cid <- mapping$ids[[k]] - if (is_missing_arg(parts[[i]])) { - next - } - is_assign_lhs <- is_assign_op && i == lhs_slot - # When recursing into an assignment LHS (e.g. `length(slot(x, nm)) <- 0L`), - # suppress wrap_call_args so that nested call arguments inside the LHS are - # not brace-wrapped. Wrapping produces e.g. `length({slot(x, nm)}) <- 0L` - # which causes R to look for the nonexistent `{<-` replacement function. - recurse_ctx <- if (is_assign_lhs && isTRUE(ctx$wrap_call_args)) { - c(ctx[names(ctx) != "wrap_call_args"], list(wrap_call_args = FALSE)) - } else { - ctx - } - value <- transform_expr(parts[[i]], cid, recurse_ctx) - # Mirror the `recurse_slot` check: do not brace-wrap an argument whose - # callee is a blacklisted primitive (e.g. `[`, `[[`, `$`, `~`). Wrapping - # these changes the deparsed form of error messages and breaks packages - # (like Matrix) that compare test output against saved `.Rout.save` files. - slot_callee_blacklisted <- is.call(parts[[i]]) && - is.symbol(parts[[i]][[1L]]) && - as.character(parts[[i]][[1L]]) %in% ctx$arg_wrap_blacklist - if (wrap_generic_args && i > 1L && !is_assign_lhs && is.call(parts[[i]]) && !is_braced(value) && !is_unquote_call(parts[[i]]) && !is_call_named(parts[[i]], ":=") && !is_unary_arith_call(parts[[i]]) && !slot_callee_blacklisted) { - value <- wrap_with_transparent_brace(value, node_srcref(cid, ctx)) - } - parts <- set_element(parts, i, value) - } - - rebuild_call(parts, expr) -} - #' Impute transparent srcrefs for injected braces in a function AST. #' #' Traverses a function's AST and wraps unbraced expressions in targeted @@ -586,6 +16,10 @@ transform_expr <- function(expr, node_id, ctx) { #' @param fn A function. #' @param wrap_call_args If `TRUE` (default), wrap generic function-call #' arguments that are call expressions. +#' @param quiet If `TRUE`, suppress the informational message emitted when a +#' function has no srcref metadata and deparse fallback is disabled. Useful +#' for callers (such as coverage tools) that process many functions and +#' handle the no-srcref case themselves. Defaults to `FALSE`. #' #' @return A function with transformed body/formals and preserved function-level #' attributes (including srcref/srcfile metadata when present). @@ -605,95 +39,6 @@ transform_expr <- function(expr, node_id, ctx) { #' g <- impute_srcrefs(f) #' g #' @export -impute_srcrefs <- function(fn, wrap_call_args = TRUE) { - if (!is.function(fn)) { - stop("`fn` must be a function", call. = FALSE) - } - if (!is.logical(wrap_call_args) || length(wrap_call_args) != 1L || is.na(wrap_call_args)) { - stop("`wrap_call_args` must be TRUE or FALSE", call. = FALSE) - } - - fn_attrs <- attributes(fn) - src <- source_text_from_srcref(fn) - if (is.null(src)) { - return(fn) - } - parsed <- tryCatch( - parse(text = src$text, keep.source = TRUE), - error = function(e) e - ) - # Functions defined inside a parenthesized call (e.g. setMethod("f", sig, - # function(x) if(cond)\n then\nelse else_expr)) rely on the surrounding `(` - # to suppress the implicit semicolon that R inserts after the then-arm on its - # own line. Parsing the extracted text standalone fails with "unexpected else". - # Retry wrapped in `(...)` to restore that syntactic context. - paren_wrapped <- FALSE - if (inherits(parsed, "error")) { - parsed <- tryCatch( - parse(text = paste0("(", src$text, ")"), keep.source = TRUE), - error = function(e) stop(conditionMessage(e), call. = FALSE) - ) - paren_wrapped <- TRUE - } - - pd <- utils::getParseData(parsed) - - if (is.null(pd) || nrow(pd) == 0L) { - stop("Could not obtain parse data for function", call. = FALSE) - } - - expr_rows <- pd[pd$token == "expr", , drop = FALSE] - if (nrow(expr_rows) == 0L) { - stop("Parse data does not contain expression nodes", call. = FALSE) - } - - root_rows <- expr_rows[expr_rows$parent == 0L, , drop = FALSE] - if (nrow(root_rows) != 1L) { - stop("Expected exactly one top-level expression for function source", call. = FALSE) - } - - root_id <- root_rows$id[[1L]] - - if (paren_wrapped) { - # The outer node is the `(...)` wrapper; descend to the actual function - # expression. The prepended `(` shifts all line-1 columns in parse data - # right by 1, so reduce first_col_offset to compensate. - inner_rows <- expr_rows[expr_rows$parent == root_id, , drop = FALSE] - if (nrow(inner_rows) != 1L) { - stop("Expected exactly one expression inside paren wrapper", call. = FALSE) - } - root_id <- inner_rows$id[[1L]] - src$first_col_offset <- src$first_col_offset - 1L - } - - # Shared parse context used by the recursive walker. - ctx <- list( - pd = pd, - expr = expr_rows, - expr_index = split(expr_rows, expr_rows$id), - srcfile = src$srcfile, - line_offset = src$line_offset, - first_col_offset = src$first_col_offset, - arg_wrap_blacklist = effective_blacklist_names(), - wrap_call_args = wrap_call_args - ) - - fn_expr <- as.call(list(as.name("function"), formals(fn), body(fn))) - # Start traversal from the top-level function expression parse node. - transformed <- transform_expr(fn_expr, root_id, ctx) - - out <- fn - transformed_formals <- transformed[[2L]] - if (!is.null(transformed_formals)) { - formals(out) <- transformed_formals - } - body(out) <- transformed[[3L]] - - if (!is.null(fn_attrs)) { - for (nm in names(fn_attrs)) { - attr(out, nm) <- fn_attrs[[nm]] - } - } - - out +impute_srcrefs <- function(fn, wrap_call_args = TRUE, quiet = FALSE) { + .Call(C_impute_srcrefs, fn, wrap_call_args, quiet) } diff --git a/R/package_srcrefs.R b/R/package_srcrefs.R index 8e4fc34..9be634a 100644 --- a/R/package_srcrefs.R +++ b/R/package_srcrefs.R @@ -1,20 +1,3 @@ -package_function_names <- function(ns, include_internal = TRUE) { - nms <- ls(ns, include_internal) - out <- character() - - for (nm in nms) { - if (!exists(nm, envir = ns, inherits = FALSE)) { - next - } - obj <- get(nm, envir = ns, inherits = FALSE) - if (is.function(obj) && !is.primitive(obj)) { - out <- c(out, nm) - } - } - - sort(unique(out)) -} - #' Check parse data for a package and impute srcrefs on all its functions. #' #' @param package Package name. @@ -28,68 +11,6 @@ package_function_names <- function(ns, include_internal = TRUE) { #' - `patched_count`: number of patched functions #' #' @export -impute_package_srcrefs <- function( - package, - include_internal = TRUE, - verbose = TRUE) { - if (!is.character(package) || length(package) != 1L || is.na(package) || identical(package, "")) { - stop("`package` must be a single non-empty package name") - } - - env <- loadNamespace(package) - fn_names <- package_function_names(env, include_internal) - failed <- character(length(fn_names)) - - - for (i in seq_along(fn_names)) { - nm <- fn_names[i] - fn <- get(nm, envir = env, inherits = FALSE) - failed[i] <- NA - - parse_data <- tryCatch(utils::getParseData(fn), error = function(e) NULL) - if (is.null(parse_data)) { - failed[i] <- "missing parse data" - next - } - - patched_fn <- tryCatch(impute_srcrefs(fn), error = function(e) e) - if (inherits(patched_fn, "error")) { - failed[i] <- paste(conditionMessage(patched_fn)) - next - } - - locked <- bindingIsLocked(nm, env) - - if (locked) { - unlockBinding(nm, env) - } - - assign(nm, patched_fn, envir = env) - - if (locked) { - lockBinding(nm, env) - } - } - - patched <- sum(is.na(failed)) - - report <- list( - package = package, - fn_names = fn_names, - failed = failed, - patched_count = patched - ) - - if (verbose) { - message( - sprintf( - "Patched %d/%d function(s) in package `%s`.", - patched, - length(fn_names), - package - ) - ) - } - - invisible(report) +impute_package_srcrefs <- function(package, include_internal = TRUE, verbose = TRUE) { + invisible(.Call(C_impute_package_srcrefs, package, include_internal, verbose)) } diff --git a/R/source_impute_srcrefs.R b/R/source_impute_srcrefs.R index 84d94ae..ecd4a78 100644 --- a/R/source_impute_srcrefs.R +++ b/R/source_impute_srcrefs.R @@ -37,67 +37,6 @@ source_impute_srcrefs <- function( toplevel.env = as.environment(envir), all.names = TRUE ) { - if (!is.character(file) || length(file) != 1L || is.na(file) || identical(file, "")) { - stop("`file` must be a single non-empty path string", call. = FALSE) - } - if (!file.exists(file)) { - stop(sprintf("File does not exist: %s", file), call. = FALSE) - } - if (!is.environment(envir)) { - stop("`envir` must be an environment", call. = FALSE) - } - - pre_names <- ls(envir, all.names = all.names) - # Snapshot pre-source bindings so we only patch functions introduced or - # modified by this source call. - pre_values <- mget(pre_names, envir = envir, inherits = FALSE, ifnotfound = vector("list", length(pre_names))) - - sys.source( - file = file, - envir = envir, - chdir = chdir, - keep.source = keep.source, - keep.parse.data = keep.parse.data, - toplevel.env = toplevel.env - ) - - post_names <- ls(envir, all.names = all.names) - imputed <- character() - - for (nm in post_names) { - if (!exists(nm, envir = envir, inherits = FALSE)) { - next - } - - value <- get(nm, envir = envir, inherits = FALSE) - if (!is.function(value)) { - next - } - - changed <- !(nm %in% pre_names) || !identical(value, pre_values[[nm]]) - if (!changed) { - next - } - - if (bindingIsLocked(nm, envir)) { - # Do not mutate locked user bindings in place. - warning(sprintf("Skipping locked binding `%s`", nm), call. = FALSE) - next - } - - # Rewrite only changed function bindings with srcref-imputed variants. - assign(nm, impute_srcrefs(value), envir = envir) - imputed <- c(imputed, nm) - } - - imputed <- sort(unique(imputed)) - - invisible(list( - file = normalizePath(file, mustWork = FALSE), - envir = envir, - functions = imputed, - count = length(imputed), - keep.source = keep.source, - keep.parse.data = keep.parse.data - )) + invisible(.Call(C_source_impute_srcrefs, file, envir, chdir, + keep.source, keep.parse.data, toplevel.env, all.names)) } diff --git a/R/srcref_sites.R b/R/srcref_sites.R index 2ae8c87..b9d074b 100644 --- a/R/srcref_sites.R +++ b/R/srcref_sites.R @@ -1,247 +1,16 @@ -deparse_one_line <- function(expr) { - # Canonical single-line representation for stable snapshot output. - txt <- paste(deparse(expr, width.cutoff = 500L), collapse = " ") - gsub("[[:space:]]+", " ", txt) -} - -format_srcref_tuple <- function(sr) { - vals <- unclass(sr) - paste0("(", paste(vals, collapse = ","), ")") -} - -srcref_to_text <- function(sr) { - # Extract exact text span covered by an srcref from its backing srcfile. - srcfile <- attr(sr, "srcfile", exact = TRUE) - if (is.null(srcfile)) { - return(NA_character_) - } - - lines <- getSrcLines(srcfile, sr[1], sr[3]) - if (length(lines) == 0L) { - return(NA_character_) - } - - if (length(lines) == 1L) { - lines[1L] <- substr(lines[1L], sr[2], sr[4]) - } else { - lines[1L] <- substr(lines[1L], sr[2], nchar(lines[1L])) - lines[length(lines)] <- substr(lines[length(lines)], 1L, sr[4]) - } - - paste(lines, collapse = "\n") -} - -canonicalize_text <- function(text) { - # Parse/deparse normalize before text comparison to avoid formatting noise. - if (is.na(text)) { - return(NA_character_) - } - - parsed <- tryCatch(parse(text = text, keep.source = FALSE), error = function(e) NULL) - if (is.null(parsed) || length(parsed) != 1L) { - return(NA_character_) - } - - deparse_one_line(parsed[[1L]]) -} +#' @useDynLib imputesrcref, .registration = TRUE +NULL -transparent_srcref <- function(node) { - # Injected transparent braces store the same srcref twice (brace + payload). - # If those entries differ, treat it as non-transparent. - sr <- attr(node, "srcref", exact = TRUE) - if (is.null(sr)) { - return(NULL) - } - - sr_list <- if (is.list(sr)) sr else list(sr) - if (length(sr_list) < 2L) { - return(NULL) - } - - if (identical(sr_list[[1L]], sr_list[[2L]])) { - return(sr_list[[1L]]) - } - - NULL -} - -strip_transparent_braces <- function(expr) { - # Remove only injected transparent braces so semantic expression comparison - # can ignore imputed wrapper calls. - if (is.call(expr)) { - if (is_braced(expr) && length(expr) >= 2L && !is.null(transparent_srcref(expr))) { - return(strip_transparent_braces(expr[[2L]])) - } - - parts <- as.list(expr) - for (i in seq_along(parts)) { - parts[[i]] <- strip_transparent_braces(parts[[i]]) - } - return(as.call(parts)) - } - - expr +collect_srcref_sites <- function(expr_or_fn) { + .Call(C_collect_srcref_sites, expr_or_fn) } collect_transparent_srcref_checks <- function(expr_or_fn) { - lines <- character() - failures <- character() - checked <- 0L - - walk <- function(node, path) { - if (is.call(node)) { - if (is_braced(node)) { - sr <- transparent_srcref(node) - if (!is.null(sr) && length(node) >= 2L) { - checked <<- checked + 1L - - sr_text <- canonicalize_text(srcref_to_text(sr)) - expr_text <- deparse_one_line(strip_transparent_braces(node[[2L]])) - ok <- !is.na(sr_text) && identical(sr_text, expr_text) - - lines <<- c( - lines, - sprintf( - "check path=%s ok=%s sr_text=%s expr_text=%s", - path, - ok, - encodeString(sr_text, quote = "\""), - encodeString(expr_text, quote = "\"") - ) - ) - - if (!ok) { - failures <<- c(failures, path) - } - } - } - - parts <- as.list(node) - for (i in seq_along(parts)) { - walk(parts[[i]], sprintf("%s/%d", path, i)) - } - return(invisible(NULL)) - } - - if (is.expression(node) || is.list(node) || is.pairlist(node)) { - for (i in seq_along(node)) { - walk(node[[i]], sprintf("%s/%d", path, i)) - } - } - - invisible(NULL) - } - - if (is.function(expr_or_fn)) { - # For functions, check both default arguments and body expressions. - fmls <- formals(expr_or_fn) - fml_text <- as.character(fmls) - - for (i in seq_along(fml_text)) { - if (identical(fml_text[[i]], "")) { - next - } - - nm <- names(fmls)[[i]] - if (is.null(nm) || identical(nm, "")) { - nm <- as.character(i) - } - - walk(fmls[[i]], sprintf("formals/%s", nm)) - } - - walk(body(expr_or_fn), "body") - } else { - walk(expr_or_fn, "root") - } - - list( - checked = checked, - ok = length(failures) == 0L, - failures = failures, - lines = lines - ) + .Call(C_collect_transparent_srcref_checks, expr_or_fn) } assert_transparent_srcref_consistency <- function(expr_or_fn) { - checks <- collect_transparent_srcref_checks(expr_or_fn) - if (!checks$ok) { - stop( - sprintf( - "Transparent srcref text mismatch at: %s", - paste(checks$failures, collapse = ", ") - ), - call. = FALSE - ) - } - invisible(checks) -} - -collect_srcref_sites <- function(expr_or_fn) { - out <- character() - - walk <- function(node, path) { - if (is.call(node)) { - if (is_braced(node)) { - sr <- attr(node, "srcref", exact = TRUE) - if (!is.null(sr)) { - sr_list <- if (is.list(sr)) sr else list(sr) - sr1 <- if (length(sr_list) >= 1L) format_srcref_tuple(sr_list[[1L]]) else "NA" - sr2 <- if (length(sr_list) >= 2L) format_srcref_tuple(sr_list[[2L]]) else "NA" - - out <<- c( - out, - sprintf( - "path=%s node=%s sr1=%s sr2=%s", - path, - deparse_one_line(node), - sr1, - sr2 - ) - ) - } - } - - parts <- as.list(node) - for (i in seq_along(parts)) { - walk(parts[[i]], sprintf("%s/%d", path, i)) - } - return(invisible(NULL)) - } - - if (is.expression(node) || is.list(node) || is.pairlist(node)) { - for (i in seq_along(node)) { - walk(node[[i]], sprintf("%s/%d", path, i)) - } - } - - invisible(NULL) - } - - if (is.function(expr_or_fn)) { - # Emit paths for formals and body so snapshots are easy to locate in AST. - fmls <- formals(expr_or_fn) - fml_text <- as.character(fmls) - - for (i in seq_along(fml_text)) { - if (identical(fml_text[[i]], "")) { - next - } - - nm <- names(fmls)[[i]] - if (is.null(nm) || identical(nm, "")) { - nm <- as.character(i) - } - - walk(fmls[[i]], sprintf("formals/%s", nm)) - } - - walk(body(expr_or_fn), "body") - } else { - walk(expr_or_fn, "root") - } - - out + invisible(.Call(C_assert_transparent_srcref_consistency, expr_or_fn)) } write_srcref_sites <- function(expr_or_fn, path) { diff --git a/README.md b/README.md index 8d52511..b256554 100644 --- a/README.md +++ b/README.md @@ -43,7 +43,9 @@ and assigns srcrefs to injected `{` calls using parse-data-derived source spans. - `source_impute_srcrefs(file, envir = parent.frame(), ...)` - Source an R file and patch all changed/new functions in the target environment. - `impute_package_srcrefs(package, include_internal = TRUE, ...)` - - Patch package namespace functions if parse data is available + - Patch package namespace functions. Works for any package whose functions + retain `srcref` metadata (the default for source installs); cached parse + data is no longer required. - `get_impute_blacklist(include_default = TRUE)` - Inspect call names excluded from generic argument wrapping. - `set_impute_blacklist(functions, append = TRUE)` @@ -51,17 +53,26 @@ and assigns srcrefs to injected `{` calls using parse-data-derived source spans. - `reset_impute_blacklist()` - Clear user blacklist entries. -## Important: package installs and parse data +## Installed packages: srcref retention -For installed packages, parse data is often missing unless the package was -installed from source with source/parse retention enabled. - -Recommended installation pattern: +`impute_package_srcrefs()` requires each function to carry a `srcref` +attribute. Source installs retain this by default. Binary installs often do +too, but if `srcref` is missing the function will be skipped (`failed[i] == +"no srcref"`). To force retention explicitly, install from source with: ```r - install.packages("", INSTALL_opts=c("--with-keep.source", "--with-keep.parse.data")) +install.packages("", INSTALL_opts = "--with-keep.source") ``` +Cached parse data (`--with-keep.parse.data`) is no longer required — +`impute_srcrefs()` re-parses from the function's source lines when no parse +data is attached. + +For functions that truly lack `srcref` (e.g. some generated closures), +`options(imputesrcref.allow_deparse_fallback = TRUE)` will impute against a +deparsed copy of the function instead, at the cost of source line numbers +shifting to the deparsed layout. + ## Usage ### Patch functions @@ -93,9 +104,9 @@ Returned fields are: - `package` - `fn_names` -- `failed` (`NA` means successfully patched) +- `failed` (`NA` means successfully patched; otherwise a short reason + such as `"no srcref"` or an error message) - `patched_count` -- `install_command` (reinstall hint when nothing could be patched) ### Blacklist API @@ -143,12 +154,42 @@ UPDATE_SNAPSHOTS=1 Rscript -e "testthat::test_dir('tests/testthat', load_package By default, mismatches fail. With `UPDATE_SNAPSHOTS=1`, the snapshot file is rewritten. -Run the optional full ggplot2 package test: +### Package corpus tests -```r -FULL_TEST=1 Rscript -e "testthat::test_file('tests/testthat/test-package-srcref-imputation.R')" +`tests/testthat/test-package-srcref-imputation.R` runs whole-package srcref +imputation over a corpus of popular packages (`data.table`, `dplyr`, `fs`, +`ggplot2`, `glue`, `jsonlite`, `stringr`, `zoo`). For each it asserts that no +function fails for an unexpected reason and that a sample of patched functions +is idempotent and srcref-text-consistent (the line-accuracy guarantee). + +These tests are slow and require the corpus packages to be installed **with +srcref retention**, so they are gated behind `FULL_TEST=1` and skip gracefully +when a package is absent or was installed without srcref. + +The `Makefile` provides targets for this. The corpus is installed into a +separate library (`CORPUS_LIB`, default `~/Rlib_test`) so your main library is +left untouched: + +```sh +make corpus-install # install the 8 corpus packages with srcref (run once) +make test-full # run the full suite including the corpus tests +``` + +Use a different library with `make test-full CORPUS_LIB=/path/to/lib`. Or run +it directly: + +```sh +FULL_TEST=1 Rscript -e \ + ".libPaths(c('~/Rlib_test', .libPaths())); testthat::test_file('tests/testthat/test-package-srcref-imputation.R')" ``` +## Implementation + +The package's internals are implemented in C and invoked from thin R wrappers +via `.Call`. Building from source requires a C toolchain (`Rtools` on +Windows, the standard `R CMD INSTALL` toolchain on macOS / Linux). No +external libraries are needed. + ## Acknowledgements This package was inspired in part by [covr](https://covr.r-lib.org/)'s parse-data handling [approach](https://github.com/r-lib/covr/blob/f1866d296c00884d1f085ff245669de01bc864c4/R/parse_data.R). diff --git a/man/impute_blacklist.Rd b/man/impute_blacklist.Rd index 947ad5a..059107d 100644 --- a/man/impute_blacklist.Rd +++ b/man/impute_blacklist.Rd @@ -1,4 +1,5 @@ -% Generated by hand; update if API changes. +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blacklist_api.R \name{get_impute_blacklist} \alias{get_impute_blacklist} \alias{set_impute_blacklist} @@ -19,20 +20,24 @@ reset_impute_blacklist() \item{append}{If \code{TRUE} append to existing user entries; otherwise replace.} } \value{ -\code{get_impute_blacklist()} returns a sorted unique character vector. - -\code{set_impute_blacklist()} invisibly returns current user-configured entries. - -\code{reset_impute_blacklist()} invisibly returns \code{character()}. +\code{get_impute_blacklist()} returns a sorted unique character vector of call +names. \code{set_impute_blacklist()} invisibly returns the current +user-configured entries. \code{reset_impute_blacklist()} invisibly returns an +empty character vector. } \description{ -\code{impute_srcrefs()} skips argument wrapping for blacklisted generic callee -names. By default, that blacklist includes primitive \code{SPECIALSXP} -functions discovered from \code{builtins()}. +By default, \code{\link[=impute_srcrefs]{impute_srcrefs()}} skips argument wrapping for primitive +\code{SPECIALSXP} calls discovered from \code{\link[=builtins]{builtins()}}. These functions inspect and +modify the user-configured portion of that blacklist. } \details{ -User entries are stored in +\itemize{ +\item \code{get_impute_blacklist()} returns the blacklist, optionally including the +built-in defaults. +\item \code{set_impute_blacklist()} adds or replaces user entries, stored in \code{options(imputesrcref.wrap_arg_blacklist = ...)}. +\item \code{reset_impute_blacklist()} clears user entries. +} } \examples{ head(get_impute_blacklist()) diff --git a/man/impute_srcrefs.Rd b/man/impute_srcrefs.Rd index 2e7b31b..2950f55 100644 --- a/man/impute_srcrefs.Rd +++ b/man/impute_srcrefs.Rd @@ -4,13 +4,18 @@ \alias{impute_srcrefs} \title{Impute transparent srcrefs for injected braces in a function AST.} \usage{ -impute_srcrefs(fn, wrap_call_args = TRUE) +impute_srcrefs(fn, wrap_call_args = TRUE, quiet = FALSE) } \arguments{ \item{fn}{A function.} \item{wrap_call_args}{If \code{TRUE} (default), wrap generic function-call arguments that are call expressions.} + +\item{quiet}{If \code{TRUE}, suppress the informational message emitted when a +function has no srcref metadata and deparse fallback is disabled. Useful +for callers (such as coverage tools) that process many functions and +handle the no-srcref case themselves. Defaults to \code{FALSE}.} } \value{ A function with transformed body/formals and preserved function-level @@ -38,8 +43,8 @@ default. To allow fallback, set \code{options(impuresrcref.allow_deparse_fallback = TRUE)}. Generic call argument wrapping skips blacklisted callee names. By default the -blacklist includes primitive \code{SPECIALSXP} calls from \code{builtins()}. -Use \code{\link[=set_impute_blacklist]{set_impute_blacklist()}} / \code{\link[=reset_impute_blacklist]{reset_impute_blacklist()}} to customize. +blacklist includes primitive \code{SPECIALSXP} calls from \code{builtins()}. Use +\code{\link[=set_impute_blacklist]{set_impute_blacklist()}} / \code{\link[=reset_impute_blacklist]{reset_impute_blacklist()}} to customize. } \examples{ options(keep.source = TRUE) diff --git a/src/blacklist.c b/src/blacklist.c new file mode 100644 index 0000000..5175816 --- /dev/null +++ b/src/blacklist.c @@ -0,0 +1,189 @@ +#include "imputesrcref.h" +#include +#include + +static SEXP specialsxp_cache = NULL; + +static const char *rlang_nse_names[] = { + "expr", "quo", "quos", "enquo", "enquos", "enexpr", "enexprs" +}; + +static SEXP compute_specialsxp_names(void) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("builtins"), R_BaseEnv)); + SEXP call = PROTECT(Rf_lang1(fn)); + SEXP nms = PROTECT(Rf_eval(call, R_GlobalEnv)); + R_xlen_t n = Rf_xlength(nms); + + int *keep = (int*) R_alloc((size_t) n, sizeof(int)); + int kept = 0; + for (R_xlen_t i = 0; i < n; i++) { + const char *nm = CHAR(STRING_ELT(nms, i)); + SEXP sym = Rf_install(nm); + SEXP obj = Rf_findVarInFrame(R_BaseEnv, sym); + if (obj != R_UnboundValue && TYPEOF(obj) == SPECIALSXP) { + keep[i] = 1; + kept++; + } else { + keep[i] = 0; + } + } + + SEXP out = PROTECT(Rf_allocVector(STRSXP, kept)); + int j = 0; + for (R_xlen_t i = 0; i < n; i++) { + if (keep[i]) { + SET_STRING_ELT(out, j++, STRING_ELT(nms, i)); + } + } + + UNPROTECT(4); + return out; +} + +static int strvec_cmp(const void *a, const void *b) { + const char *sa = CHAR(*(SEXP const*) a); + const char *sb = CHAR(*(SEXP const*) b); + return strcmp(sa, sb); +} + +static SEXP sort_unique_strvec(SEXP x) { + R_xlen_t n = Rf_xlength(x); + if (n == 0) return x; + SEXP *buf = (SEXP*) R_alloc((size_t) n, sizeof(SEXP)); + for (R_xlen_t i = 0; i < n; i++) buf[i] = STRING_ELT(x, i); + qsort(buf, (size_t) n, sizeof(SEXP), strvec_cmp); + int u = 0; + for (R_xlen_t i = 0; i < n; i++) { + if (i == 0 || strcmp(CHAR(buf[i]), CHAR(buf[u-1])) != 0) { + buf[u++] = buf[i]; + } + } + SEXP out = PROTECT(Rf_allocVector(STRSXP, u)); + for (int i = 0; i < u; i++) SET_STRING_ELT(out, i, buf[i]); + UNPROTECT(1); + return out; +} + +static SEXP normalize_blacklist(SEXP x, const char *arg) { + if (x == R_NilValue) return Rf_allocVector(STRSXP, 0); + if (TYPEOF(x) != STRSXP) { + Rf_error("`%s` must be NULL or a character vector", arg); + } + R_xlen_t n = Rf_xlength(x); + SEXP keep = PROTECT(Rf_allocVector(STRSXP, n)); + int k = 0; + for (R_xlen_t i = 0; i < n; i++) { + SEXP s = STRING_ELT(x, i); + if (s == NA_STRING) continue; + const char *raw = CHAR(s); + /* trim whitespace */ + const char *p = raw; + while (*p == ' ' || *p == '\t' || *p == '\n' || *p == '\r') p++; + const char *q = raw + strlen(raw); + while (q > p && (q[-1] == ' ' || q[-1] == '\t' || q[-1] == '\n' || q[-1] == '\r')) q--; + if (q == p) continue; + int len = (int)(q - p); + char *buf = (char*) R_alloc((size_t)(len + 1), sizeof(char)); + memcpy(buf, p, (size_t) len); + buf[len] = '\0'; + SET_STRING_ELT(keep, k++, Rf_mkChar(buf)); + } + SEXP trimmed = PROTECT(Rf_allocVector(STRSXP, k)); + for (int i = 0; i < k; i++) SET_STRING_ELT(trimmed, i, STRING_ELT(keep, i)); + SEXP res = sort_unique_strvec(trimmed); + UNPROTECT(2); + return res; +} + +static SEXP user_blacklist(void) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("getOption"), R_BaseEnv)); + SEXP a = PROTECT(Rf_mkString("imputesrcref.wrap_arg_blacklist")); + SEXP call = PROTECT(Rf_lang2(fn, a)); + SEXP v = PROTECT(Rf_eval(call, R_GlobalEnv)); + SEXP res = normalize_blacklist(v, "imputesrcref.wrap_arg_blacklist"); + UNPROTECT(4); + return res; +} + +static SEXP get_specialsxp(void) { + if (specialsxp_cache == NULL) { + SEXP v = compute_specialsxp_names(); + PROTECT(v); + R_PreserveObject(v); + UNPROTECT(1); + specialsxp_cache = v; + } + return specialsxp_cache; +} + +SEXP imputesrcref_effective_blacklist(void) { + SEXP special = PROTECT(get_specialsxp()); + SEXP user = PROTECT(user_blacklist()); + + R_xlen_t n1 = Rf_xlength(special); + R_xlen_t n2 = (R_xlen_t) (sizeof(rlang_nse_names) / sizeof(rlang_nse_names[0])); + R_xlen_t n3 = Rf_xlength(user); + + SEXP combined = PROTECT(Rf_allocVector(STRSXP, n1 + n2 + n3)); + R_xlen_t pos = 0; + for (R_xlen_t i = 0; i < n1; i++) SET_STRING_ELT(combined, pos++, STRING_ELT(special, i)); + for (R_xlen_t i = 0; i < n2; i++) SET_STRING_ELT(combined, pos++, Rf_mkChar(rlang_nse_names[i])); + for (R_xlen_t i = 0; i < n3; i++) SET_STRING_ELT(combined, pos++, STRING_ELT(user, i)); + + SEXP res = sort_unique_strvec(combined); + UNPROTECT(3); + return res; +} + +SEXP C_get_impute_blacklist(SEXP include_default) { + if (TYPEOF(include_default) != LGLSXP || Rf_xlength(include_default) != 1 || + LOGICAL(include_default)[0] == NA_LOGICAL) { + Rf_error("`include_default` must be TRUE or FALSE"); + } + if (LOGICAL(include_default)[0]) { + return imputesrcref_effective_blacklist(); + } + return user_blacklist(); +} + +static void set_option(const char *name, SEXP value) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("options"), R_BaseEnv)); + SEXP call = PROTECT(Rf_lang2(fn, value)); + SET_TAG(CDR(call), Rf_install(name)); + Rf_eval(call, R_GlobalEnv); + UNPROTECT(2); +} + +SEXP C_set_impute_blacklist(SEXP functions, SEXP append) { + if (TYPEOF(append) != LGLSXP || Rf_xlength(append) != 1 || + LOGICAL(append)[0] == NA_LOGICAL) { + Rf_error("`append` must be TRUE or FALSE"); + } + int do_append = LOGICAL(append)[0]; + + SEXP incoming = PROTECT(normalize_blacklist(functions, "functions")); + SEXP current = R_NilValue; + if (do_append) { + current = PROTECT(user_blacklist()); + } else { + current = PROTECT(Rf_allocVector(STRSXP, 0)); + } + + R_xlen_t n1 = Rf_xlength(current); + R_xlen_t n2 = Rf_xlength(incoming); + SEXP combined = PROTECT(Rf_allocVector(STRSXP, n1 + n2)); + R_xlen_t pos = 0; + for (R_xlen_t i = 0; i < n1; i++) SET_STRING_ELT(combined, pos++, STRING_ELT(current, i)); + for (R_xlen_t i = 0; i < n2; i++) SET_STRING_ELT(combined, pos++, STRING_ELT(incoming, i)); + SEXP next_vals = PROTECT(sort_unique_strvec(combined)); + + set_option("imputesrcref.wrap_arg_blacklist", next_vals); + + UNPROTECT(4); + return next_vals; +} + +SEXP C_reset_impute_blacklist(void) { + set_option("imputesrcref.wrap_arg_blacklist", R_NilValue); + return Rf_allocVector(STRSXP, 0); +} diff --git a/src/helpers.c b/src/helpers.c new file mode 100644 index 0000000..5866359 --- /dev/null +++ b/src/helpers.c @@ -0,0 +1,274 @@ +#include "imputesrcref.h" +#include +#include + +int imputesrcref_is_call_named(SEXP expr, const char *name) { + if (TYPEOF(expr) != LANGSXP) return 0; + SEXP head = CAR(expr); + if (TYPEOF(head) != SYMSXP) return 0; + return strcmp(CHAR(PRINTNAME(head)), name) == 0; +} + +int imputesrcref_is_braced(SEXP expr) { + return imputesrcref_is_call_named(expr, "{"); +} + +int imputesrcref_is_missing_arg(SEXP x) { + return TYPEOF(x) == SYMSXP && CHAR(PRINTNAME(x))[0] == '\0'; +} + +int imputesrcref_is_logical_op_call(SEXP expr) { + if (TYPEOF(expr) != LANGSXP) return 0; + SEXP head = CAR(expr); + if (TYPEOF(head) != SYMSXP) return 0; + const char *nm = CHAR(PRINTNAME(head)); + return strcmp(nm, "&&") == 0 || strcmp(nm, "||") == 0 || + strcmp(nm, "&") == 0 || strcmp(nm, "|") == 0; +} + +int imputesrcref_is_unquote_call(SEXP expr) { + if (TYPEOF(expr) != LANGSXP) return 0; + R_xlen_t n = Rf_xlength(expr); + if (n != 2) return 0; + SEXP head = CAR(expr); + if (TYPEOF(head) != SYMSXP) return 0; + const char *nm = CHAR(PRINTNAME(head)); + if (strcmp(nm, "!") == 0) { + SEXP inner = CADR(expr); + if (TYPEOF(inner) != LANGSXP) return 0; + if (Rf_xlength(inner) != 2) return 0; + SEXP ihead = CAR(inner); + return TYPEOF(ihead) == SYMSXP && strcmp(CHAR(PRINTNAME(ihead)), "!") == 0; + } + if (strcmp(nm, "(") == 0) { + return imputesrcref_is_unquote_call(CADR(expr)); + } + return 0; +} + +int imputesrcref_is_unary_arith_call(SEXP expr) { + if (TYPEOF(expr) != LANGSXP) return 0; + if (Rf_xlength(expr) != 2) return 0; + SEXP head = CAR(expr); + if (TYPEOF(head) != SYMSXP) return 0; + const char *nm = CHAR(PRINTNAME(head)); + return strcmp(nm, "-") == 0 || strcmp(nm, "+") == 0; +} + +int imputesrcref_in_strvec(SEXP vec, const char *name) { + if (TYPEOF(vec) != STRSXP) return 0; + R_xlen_t n = Rf_xlength(vec); + for (R_xlen_t i = 0; i < n; i++) { + SEXP s = STRING_ELT(vec, i); + if (s != NA_STRING && strcmp(CHAR(s), name) == 0) return 1; + } + return 0; +} + +static int get_int_col(SEXP df, const char *name, int **out) { + SEXP nms = Rf_getAttrib(df, R_NamesSymbol); + R_xlen_t n = Rf_xlength(nms); + for (R_xlen_t i = 0; i < n; i++) { + if (strcmp(CHAR(STRING_ELT(nms, i)), name) == 0) { + SEXP col = VECTOR_ELT(df, i); + if (TYPEOF(col) != INTSXP) Rf_error("Column `%s` is not integer", name); + *out = INTEGER(col); + return (int) Rf_xlength(col); + } + } + Rf_error("Column `%s` not found in parse data", name); + return -1; +} + +static SEXP get_str_col(SEXP df, const char *name) { + SEXP nms = Rf_getAttrib(df, R_NamesSymbol); + R_xlen_t n = Rf_xlength(nms); + for (R_xlen_t i = 0; i < n; i++) { + if (strcmp(CHAR(STRING_ELT(nms, i)), name) == 0) { + SEXP col = VECTOR_ELT(df, i); + if (TYPEOF(col) != STRSXP) Rf_error("Column `%s` is not character", name); + return col; + } + } + Rf_error("Column `%s` not found in parse data", name); + return R_NilValue; +} + +typedef struct { + int *id_arr; + int *line1_arr; + int *col1_arr; +} sort_ctx; + +static sort_ctx *g_sort_ctx; + +static int cmp_expr_child(const void *a, const void *b) { + int ia = *(const int*) a; + int ib = *(const int*) b; + int ra = g_sort_ctx->id_arr[ia]; + int rb = g_sort_ctx->id_arr[ib]; + (void) ra; (void) rb; + int la = g_sort_ctx->line1_arr[ia]; + int lb = g_sort_ctx->line1_arr[ib]; + if (la != lb) return la - lb; + int ca = g_sort_ctx->col1_arr[ia]; + int cb = g_sort_ctx->col1_arr[ib]; + if (ca != cb) return ca - cb; + return g_sort_ctx->id_arr[ia] - g_sort_ctx->id_arr[ib]; +} + +void imputesrcref_build_ctx(parse_ctx *ctx, SEXP pd, SEXP srcfile, + int line_offset, int first_col_offset, + SEXP arg_wrap_blacklist, int wrap_call_args) { + ctx->pd = pd; + ctx->srcfile = srcfile; + ctx->line_offset = line_offset; + ctx->first_col_offset = first_col_offset; + ctx->abs_lines = R_NilValue; + ctx->n_abs_lines = 0; + ctx->abs_lines_start = 1; + ctx->arg_wrap_blacklist = arg_wrap_blacklist; + ctx->wrap_call_args = wrap_call_args; + + int n1 = get_int_col(pd, "id", &ctx->id); + int n2 = get_int_col(pd, "parent", &ctx->parent); + int n3 = get_int_col(pd, "line1", &ctx->line1); + int n4 = get_int_col(pd, "col1", &ctx->col1); + int n5 = get_int_col(pd, "line2", &ctx->line2); + int n6 = get_int_col(pd, "col2", &ctx->col2); + if (!(n1 == n2 && n1 == n3 && n1 == n4 && n1 == n5 && n1 == n6)) { + Rf_error("Parse data columns have differing lengths"); + } + ctx->nrow = n1; + ctx->token = get_str_col(pd, "token"); + + int max_id = 0; + for (int i = 0; i < ctx->nrow; i++) { + if (ctx->id[i] > max_id) max_id = ctx->id[i]; + } + ctx->max_id = max_id; + + ctx->id_to_pdrow = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + for (int i = 0; i <= max_id + 1; i++) ctx->id_to_pdrow[i] = -1; + for (int i = 0; i < ctx->nrow; i++) { + if (ctx->id[i] >= 0 && ctx->id[i] <= max_id) { + ctx->id_to_pdrow[ctx->id[i]] = i; + } + } + + int *all_counts = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + int *expr_counts = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + for (int i = 0; i <= max_id + 1; i++) { all_counts[i] = 0; expr_counts[i] = 0; } + + int *is_expr_row = (int*) R_alloc((size_t) ctx->nrow, sizeof(int)); + for (int i = 0; i < ctx->nrow; i++) { + is_expr_row[i] = (strcmp(CHAR(STRING_ELT(ctx->token, i)), "expr") == 0) ? 1 : 0; + } + + for (int i = 0; i < ctx->nrow; i++) { + int p = ctx->parent[i]; + if (p >= 0 && p <= max_id) { + all_counts[p]++; + if (is_expr_row[i]) expr_counts[p]++; + } + } + + ctx->all_children_offset = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + ctx->all_children_count = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + ctx->expr_children_offset = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + ctx->expr_children_count = (int*) R_alloc((size_t)(max_id + 2), sizeof(int)); + + int all_total = 0, expr_total = 0; + for (int i = 0; i <= max_id + 1; i++) { + ctx->all_children_offset[i] = all_total; + ctx->expr_children_offset[i] = expr_total; + ctx->all_children_count[i] = 0; + ctx->expr_children_count[i] = 0; + all_total += all_counts[i]; + expr_total += expr_counts[i]; + } + + ctx->all_children_data = (int*) R_alloc((size_t)(all_total > 0 ? all_total : 1), sizeof(int)); + ctx->expr_children_data = (int*) R_alloc((size_t)(expr_total > 0 ? expr_total : 1), sizeof(int)); + + for (int i = 0; i < ctx->nrow; i++) { + int p = ctx->parent[i]; + if (p < 0 || p > max_id) continue; + int pos = ctx->all_children_offset[p] + ctx->all_children_count[p]++; + ctx->all_children_data[pos] = i; + if (is_expr_row[i]) { + int epos = ctx->expr_children_offset[p] + ctx->expr_children_count[p]++; + ctx->expr_children_data[epos] = i; + } + } + + sort_ctx sctx; + sctx.id_arr = ctx->id; + sctx.line1_arr = ctx->line1; + sctx.col1_arr = ctx->col1; + g_sort_ctx = &sctx; + for (int p = 0; p <= max_id; p++) { + int cnt = ctx->expr_children_count[p]; + if (cnt > 1) { + qsort(ctx->expr_children_data + ctx->expr_children_offset[p], + (size_t) cnt, sizeof(int), cmp_expr_child); + } + } + g_sort_ctx = NULL; +} + +SEXP imputesrcref_node_srcref(int node_id, parse_ctx *ctx) { + if (node_id < 0 || node_id > ctx->max_id) Rf_error("Missing parse node id %d", node_id); + int row = ctx->id_to_pdrow[node_id]; + if (row < 0) Rf_error("Missing parse node id %d", node_id); + int rl1 = ctx->line1[row]; + int rl2 = ctx->line2[row]; + + int l1 = rl1 + ctx->line_offset; + int l2 = rl2 + ctx->line_offset; + /* Visual (tab-expanded) columns in the original-file coordinate system. */ + int c1 = ctx->col1[row] + (rl1 == 1 ? ctx->first_col_offset : 0); + int c2 = ctx->col2[row] + (rl2 == 1 ? ctx->first_col_offset : 0); + + /* Byte offsets for the srcref byte slots (2 and 4). R stores bytes there + and visual columns in slots 5/6; `as.character.srcref` (used by deparse, + getSrcref and covr) slices source by the byte slots. The parse data only + gives visual columns, so convert against the absolute source line. `l1` + and `c1` are already absolute coordinates, so this works uniformly for + the paren-wrapped and deparse-fallback cases. Fall back to the visual + value when the line is unavailable. */ + int b1 = c1, b2 = c2; + if (ctx->abs_lines != R_NilValue) { + int idx1 = l1 - ctx->abs_lines_start; + int idx2 = l2 - ctx->abs_lines_start; + if (idx1 >= 0 && idx1 < ctx->n_abs_lines) { + b1 = imputesrcref_visual_col_to_byte_col( + CHAR(STRING_ELT(ctx->abs_lines, idx1)), c1); + } + if (idx2 >= 0 && idx2 < ctx->n_abs_lines) { + b2 = imputesrcref_visual_col_to_byte_col( + CHAR(STRING_ELT(ctx->abs_lines, idx2)), c2); + } + } + + SEXP sr = PROTECT(Rf_allocVector(INTSXP, 8)); + int *p = INTEGER(sr); + p[0] = l1; p[1] = b1; p[2] = l2; p[3] = b2; + p[4] = c1; p[5] = c2; p[6] = l1; p[7] = l2; + Rf_setAttrib(sr, Rf_install("srcfile"), ctx->srcfile); + SEXP cls = PROTECT(Rf_mkString("srcref")); + Rf_setAttrib(sr, R_ClassSymbol, cls); + UNPROTECT(2); + return sr; +} + +SEXP imputesrcref_wrap_brace(SEXP expr, SEXP sr) { + SEXP brace = PROTECT(Rf_install("{")); + SEXP out = PROTECT(Rf_lang2(brace, expr)); + SEXP srlist = PROTECT(Rf_allocVector(VECSXP, 2)); + SET_VECTOR_ELT(srlist, 0, sr); + SET_VECTOR_ELT(srlist, 1, sr); + Rf_setAttrib(out, Rf_install("srcref"), srlist); + UNPROTECT(3); + return out; +} diff --git a/src/imputesrcref.h b/src/imputesrcref.h new file mode 100644 index 0000000..627cd2d --- /dev/null +++ b/src/imputesrcref.h @@ -0,0 +1,78 @@ +#ifndef IMPUTESRCREF_H +#define IMPUTESRCREF_H + +#define R_NO_REMAP +#include +#include +#include + +typedef struct parse_ctx { + SEXP pd; + int nrow; + int *id; + int *parent; + int *line1; + int *col1; + int *line2; + int *col2; + SEXP token; + int max_id; + int *id_to_pdrow; + int *all_children_offset; + int *all_children_count; + int *all_children_data; + int *expr_children_offset; + int *expr_children_count; + int *expr_children_data; + SEXP srcfile; + int line_offset; + int first_col_offset; + /* Untrimmed source lines spanned by the function, used to convert the + parse data's visual (tab-expanded) columns into byte offsets for the + srcref byte slots. `abs_lines[k]` is original-file line + `abs_lines_start + k`. */ + SEXP abs_lines; + int n_abs_lines; + int abs_lines_start; + SEXP arg_wrap_blacklist; + int wrap_call_args; +} parse_ctx; + +void imputesrcref_build_ctx(parse_ctx *ctx, SEXP pd, SEXP srcfile, + int line_offset, int first_col_offset, + SEXP arg_wrap_blacklist, int wrap_call_args); + +int imputesrcref_is_call_named(SEXP expr, const char *name); +int imputesrcref_is_braced(SEXP expr); +int imputesrcref_is_missing_arg(SEXP x); +int imputesrcref_is_logical_op_call(SEXP expr); +int imputesrcref_is_unquote_call(SEXP expr); +int imputesrcref_is_unary_arith_call(SEXP expr); +int imputesrcref_in_strvec(SEXP vec, const char *name); + +SEXP imputesrcref_node_srcref(int node_id, parse_ctx *ctx); +SEXP imputesrcref_wrap_brace(SEXP expr, SEXP sr); +SEXP imputesrcref_transform_expr(SEXP expr, int node_id, parse_ctx *ctx); + +SEXP imputesrcref_source_text(SEXP fn); + +extern int imputesrcref_quiet; + +int imputesrcref_visual_col_to_byte_col(const char *line, int visual_col); + +SEXP imputesrcref_effective_blacklist(void); + +SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args, SEXP quiet); +SEXP C_get_impute_blacklist(SEXP include_default); +SEXP C_set_impute_blacklist(SEXP functions, SEXP append); +SEXP C_reset_impute_blacklist(void); +SEXP C_impute_package_srcrefs(SEXP package, SEXP include_internal, SEXP verbose); +SEXP C_source_impute_srcrefs(SEXP file, SEXP envir, SEXP chdir, + SEXP keep_source, SEXP keep_parse_data, + SEXP toplevel_env, SEXP all_names); + +SEXP C_collect_srcref_sites(SEXP expr_or_fn); +SEXP C_collect_transparent_srcref_checks(SEXP expr_or_fn); +SEXP C_assert_transparent_srcref_consistency(SEXP expr_or_fn); + +#endif diff --git a/src/init.c b/src/init.c new file mode 100644 index 0000000..3ab7d22 --- /dev/null +++ b/src/init.c @@ -0,0 +1,20 @@ +#include "imputesrcref.h" + +static const R_CallMethodDef CallEntries[] = { + {"C_impute_srcrefs", (DL_FUNC) &C_impute_srcrefs, 3}, + {"C_get_impute_blacklist", (DL_FUNC) &C_get_impute_blacklist, 1}, + {"C_set_impute_blacklist", (DL_FUNC) &C_set_impute_blacklist, 2}, + {"C_reset_impute_blacklist", (DL_FUNC) &C_reset_impute_blacklist, 0}, + {"C_impute_package_srcrefs", (DL_FUNC) &C_impute_package_srcrefs, 3}, + {"C_source_impute_srcrefs", (DL_FUNC) &C_source_impute_srcrefs, 7}, + {"C_collect_srcref_sites", (DL_FUNC) &C_collect_srcref_sites, 1}, + {"C_collect_transparent_srcref_checks", (DL_FUNC) &C_collect_transparent_srcref_checks, 1}, + {"C_assert_transparent_srcref_consistency", (DL_FUNC) &C_assert_transparent_srcref_consistency, 1}, + {NULL, NULL, 0} +}; + +void R_init_imputesrcref(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); + R_forceSymbols(dll, TRUE); +} diff --git a/src/source_impute.c b/src/source_impute.c new file mode 100644 index 0000000..a9bdfc2 --- /dev/null +++ b/src/source_impute.c @@ -0,0 +1,410 @@ +#include "imputesrcref.h" +#include +#include + +static SEXP base_fun(const char *name) { + return Rf_findFun(Rf_install(name), R_BaseEnv); +} + +static SEXP one_arg_call(SEXP fn, SEXP a1) { + SEXP c = PROTECT(Rf_lang2(fn, a1)); + SEXP r = Rf_eval(c, R_GlobalEnv); + UNPROTECT(1); + return r; +} + +static SEXP two_arg_call(SEXP fn, SEXP a1, SEXP a2) { + SEXP c = PROTECT(Rf_lang3(fn, a1, a2)); + SEXP r = Rf_eval(c, R_GlobalEnv); + UNPROTECT(1); + return r; +} + +static SEXP ls_env(SEXP envir, int all_names) { + SEXP fn = PROTECT(base_fun("ls")); + SEXP a = PROTECT(Rf_ScalarLogical(all_names)); + SEXP call = PROTECT(Rf_lang3(fn, envir, a)); + SET_TAG(CDDR(call), Rf_install("all.names")); + SEXP r = Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); + return r; +} + +static int exists_in(const char *name, SEXP envir) { + SEXP fn = PROTECT(base_fun("exists")); + SEXP nm = PROTECT(Rf_mkString(name)); + SEXP inh = PROTECT(Rf_ScalarLogical(0)); + SEXP call = PROTECT(Rf_lang4(fn, nm, envir, inh)); + SET_TAG(CDDR(call), Rf_install("envir")); + SET_TAG(CDR(CDDR(call)), Rf_install("inherits")); + SEXP r = PROTECT(Rf_eval(call, R_GlobalEnv)); + int v = LOGICAL(r)[0] == TRUE; + UNPROTECT(5); + return v; +} + +static SEXP get_in(const char *name, SEXP envir) { + SEXP fn = PROTECT(base_fun("get")); + SEXP nm = PROTECT(Rf_mkString(name)); + SEXP inh = PROTECT(Rf_ScalarLogical(0)); + SEXP call = PROTECT(Rf_lang4(fn, nm, envir, inh)); + SET_TAG(CDDR(call), Rf_install("envir")); + SET_TAG(CDR(CDDR(call)), Rf_install("inherits")); + SEXP r = Rf_eval(call, R_GlobalEnv); + UNPROTECT(4); + return r; +} + +static int identical_(SEXP a, SEXP b) { + SEXP fn = PROTECT(base_fun("identical")); + SEXP qa = PROTECT(Rf_lang2(Rf_install("quote"), a)); + SEXP qb = PROTECT(Rf_lang2(Rf_install("quote"), b)); + SEXP call = PROTECT(Rf_lang3(fn, qa, qb)); + SEXP r = PROTECT(Rf_eval(call, R_GlobalEnv)); + int v = TYPEOF(r) == LGLSXP && LOGICAL(r)[0] == TRUE; + UNPROTECT(5); + return v; +} + +static void assign_in(const char *name, SEXP value, SEXP envir) { + SEXP fn = PROTECT(base_fun("assign")); + SEXP nm = PROTECT(Rf_mkString(name)); + SEXP call = PROTECT(Rf_lang4(fn, nm, value, envir)); + SET_TAG(CDR(CDDR(call)), Rf_install("envir")); + Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); +} + +static int binding_is_locked(const char *name, SEXP envir) { + SEXP fn = PROTECT(base_fun("bindingIsLocked")); + SEXP nm = PROTECT(Rf_mkString(name)); + SEXP r = PROTECT(two_arg_call(fn, nm, envir)); + int v = TYPEOF(r) == LGLSXP && LOGICAL(r)[0] == TRUE; + UNPROTECT(3); + return v; +} + +static void unlock_binding_(const char *name, SEXP envir) { + SEXP fn = PROTECT(base_fun("unlockBinding")); + SEXP nm = PROTECT(Rf_mkString(name)); + two_arg_call(fn, nm, envir); + UNPROTECT(2); +} + +static void lock_binding_(const char *name, SEXP envir) { + SEXP fn = PROTECT(base_fun("lockBinding")); + SEXP nm = PROTECT(Rf_mkString(name)); + two_arg_call(fn, nm, envir); + UNPROTECT(2); +} + +static void emit_warning(const char *txt) { + SEXP fn = PROTECT(base_fun("warning")); + SEXP nm = PROTECT(Rf_mkString(txt)); + SEXP cf = PROTECT(Rf_ScalarLogical(0)); + SEXP call = PROTECT(Rf_lang3(fn, nm, cf)); + SET_TAG(CDDR(call), Rf_install("call.")); + Rf_eval(call, R_GlobalEnv); + UNPROTECT(4); +} + +static void emit_message(const char *txt) { + SEXP fn = PROTECT(base_fun("message")); + SEXP nm = PROTECT(Rf_mkString(txt)); + one_arg_call(fn, nm); + UNPROTECT(2); +} + +static void sys_source_(SEXP file, SEXP envir, SEXP chdir, SEXP keep_source, + SEXP keep_parse_data, SEXP toplevel_env) { + SEXP fn = PROTECT(base_fun("sys.source")); + SEXP call = PROTECT(Rf_allocList(7)); + SET_TYPEOF(call, LANGSXP); + SETCAR(call, fn); + SEXP c1 = CDR(call); SETCAR(c1, file); SET_TAG(c1, Rf_install("file")); + SEXP c2 = CDR(c1); SETCAR(c2, envir); SET_TAG(c2, Rf_install("envir")); + SEXP c3 = CDR(c2); SETCAR(c3, chdir); SET_TAG(c3, Rf_install("chdir")); + SEXP c4 = CDR(c3); SETCAR(c4, keep_source); SET_TAG(c4, Rf_install("keep.source")); + SEXP c5 = CDR(c4); SETCAR(c5, keep_parse_data); SET_TAG(c5, Rf_install("keep.parse.data")); + SEXP c6 = CDR(c5); SETCAR(c6, toplevel_env); SET_TAG(c6, Rf_install("toplevel.env")); + Rf_eval(call, R_GlobalEnv); + UNPROTECT(2); +} + +static SEXP normalize_path_(SEXP file) { + SEXP fn = PROTECT(base_fun("normalizePath")); + SEXP mw = PROTECT(Rf_ScalarLogical(0)); + SEXP call = PROTECT(Rf_lang3(fn, file, mw)); + SET_TAG(CDDR(call), Rf_install("mustWork")); + SEXP r = Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); + return r; +} + +static int file_exists_(SEXP file) { + SEXP fn = PROTECT(base_fun("file.exists")); + SEXP r = PROTECT(one_arg_call(fn, file)); + int v = TYPEOF(r) == LGLSXP && LOGICAL(r)[0] == TRUE; + UNPROTECT(2); + return v; +} + +static SEXP load_namespace_(const char *pkg) { + SEXP fn = PROTECT(base_fun("loadNamespace")); + SEXP nm = PROTECT(Rf_mkString(pkg)); + SEXP r = one_arg_call(fn, nm); + UNPROTECT(2); + return r; +} + +static int is_primitive_(SEXP x) { + return TYPEOF(x) == BUILTINSXP || TYPEOF(x) == SPECIALSXP; +} + +static SEXP sort_unique_strvec(SEXP x) { + SEXP unique_fn = PROTECT(base_fun("unique")); + SEXP u = PROTECT(one_arg_call(unique_fn, x)); + SEXP sort_fn = PROTECT(base_fun("sort")); + SEXP r = one_arg_call(sort_fn, u); + UNPROTECT(3); + return r; +} + +typedef struct { + SEXP fn; +} impute_body_data; + +static SEXP impute_body(void *data) { + impute_body_data *bd = (impute_body_data*) data; + /* Batch ops already raise the ambient `imputesrcref_quiet` flag, so the + per-call quiet arg can stay FALSE here. */ + return C_impute_srcrefs(bd->fn, Rf_ScalarLogical(1), Rf_ScalarLogical(0)); +} + +static char err_msg_buf[2048]; + +static SEXP impute_handler(SEXP cond, void *data) { + (void) data; + SEXP cm_fn = PROTECT(base_fun("conditionMessage")); + SEXP call = PROTECT(Rf_lang2(cm_fn, cond)); + SEXP msg = PROTECT(Rf_eval(call, R_GlobalEnv)); + const char *m = (TYPEOF(msg) == STRSXP && Rf_xlength(msg) >= 1) + ? CHAR(STRING_ELT(msg, 0)) : ""; + strncpy(err_msg_buf, m, sizeof(err_msg_buf) - 1); + err_msg_buf[sizeof(err_msg_buf) - 1] = '\0'; + UNPROTECT(3); + return R_NilValue; +} + +static SEXP try_impute_srcrefs(SEXP fn, int *err, char *msg_out, size_t msg_size) { + err_msg_buf[0] = '\0'; + impute_body_data bd = { fn }; + SEXP res = R_tryCatchError(impute_body, &bd, impute_handler, NULL); + if (err_msg_buf[0] != '\0') { + *err = 1; + if (msg_out && msg_size > 0) { + strncpy(msg_out, err_msg_buf, msg_size - 1); + msg_out[msg_size - 1] = '\0'; + } + return R_NilValue; + } + *err = 0; + return res; +} + +SEXP C_source_impute_srcrefs(SEXP file, SEXP envir, SEXP chdir, + SEXP keep_source, SEXP keep_parse_data, + SEXP toplevel_env, SEXP all_names) { + if (TYPEOF(file) != STRSXP || Rf_xlength(file) != 1 || + STRING_ELT(file, 0) == NA_STRING || CHAR(STRING_ELT(file, 0))[0] == '\0') { + Rf_error("`file` must be a single non-empty path string"); + } + if (!file_exists_(file)) { + Rf_error("File does not exist: %s", CHAR(STRING_ELT(file, 0))); + } + if (TYPEOF(envir) != ENVSXP) { + Rf_error("`envir` must be an environment"); + } + int all = (TYPEOF(all_names) == LGLSXP && Rf_xlength(all_names) >= 1) + ? LOGICAL(all_names)[0] : 1; + + SEXP pre_names = PROTECT(ls_env(envir, all)); + R_xlen_t n_pre = Rf_xlength(pre_names); + SEXP pre_values = PROTECT(Rf_allocVector(VECSXP, n_pre)); + for (R_xlen_t i = 0; i < n_pre; i++) { + const char *nm = CHAR(STRING_ELT(pre_names, i)); + if (exists_in(nm, envir)) { + SET_VECTOR_ELT(pre_values, i, get_in(nm, envir)); + } + } + + sys_source_(file, envir, chdir, keep_source, keep_parse_data, toplevel_env); + + SEXP post_names = PROTECT(ls_env(envir, all)); + R_xlen_t n_post = Rf_xlength(post_names); + + SEXP imputed = PROTECT(Rf_allocVector(STRSXP, n_post)); + int n_imputed = 0; + + int saved_quiet = imputesrcref_quiet; + imputesrcref_quiet = 1; + + for (R_xlen_t i = 0; i < n_post; i++) { + const char *nm = CHAR(STRING_ELT(post_names, i)); + if (!exists_in(nm, envir)) continue; + SEXP value = PROTECT(get_in(nm, envir)); + if (!Rf_isFunction(value)) { UNPROTECT(1); continue; } + + int in_pre = 0; + R_xlen_t pre_idx = -1; + for (R_xlen_t j = 0; j < n_pre; j++) { + if (strcmp(CHAR(STRING_ELT(pre_names, j)), nm) == 0) { + in_pre = 1; + pre_idx = j; + break; + } + } + int changed = !in_pre || !identical_(value, VECTOR_ELT(pre_values, pre_idx)); + if (!changed) { UNPROTECT(1); continue; } + + if (binding_is_locked(nm, envir)) { + char msg[512]; + snprintf(msg, sizeof(msg), "Skipping locked binding `%s`", nm); + emit_warning(msg); + UNPROTECT(1); + continue; + } + + int err = 0; + SEXP imputed_fn = PROTECT(try_impute_srcrefs(value, &err, NULL, 0)); + if (err) { UNPROTECT(2); continue; } + assign_in(nm, imputed_fn, envir); + SET_STRING_ELT(imputed, n_imputed++, STRING_ELT(post_names, i)); + UNPROTECT(2); + } + + imputesrcref_quiet = saved_quiet; + + SEXP imputed_trim = PROTECT(Rf_allocVector(STRSXP, n_imputed)); + for (int i = 0; i < n_imputed; i++) SET_STRING_ELT(imputed_trim, i, STRING_ELT(imputed, i)); + + SEXP final_names = PROTECT(sort_unique_strvec(imputed_trim)); + SEXP normalized = PROTECT(normalize_path_(file)); + + SEXP out = PROTECT(Rf_allocVector(VECSXP, 6)); + SEXP nms = PROTECT(Rf_allocVector(STRSXP, 6)); + SET_STRING_ELT(nms, 0, Rf_mkChar("file")); + SET_STRING_ELT(nms, 1, Rf_mkChar("envir")); + SET_STRING_ELT(nms, 2, Rf_mkChar("functions")); + SET_STRING_ELT(nms, 3, Rf_mkChar("count")); + SET_STRING_ELT(nms, 4, Rf_mkChar("keep.source")); + SET_STRING_ELT(nms, 5, Rf_mkChar("keep.parse.data")); + Rf_setAttrib(out, R_NamesSymbol, nms); + SET_VECTOR_ELT(out, 0, normalized); + SET_VECTOR_ELT(out, 1, envir); + SET_VECTOR_ELT(out, 2, final_names); + SET_VECTOR_ELT(out, 3, Rf_ScalarInteger((int) Rf_xlength(final_names))); + SET_VECTOR_ELT(out, 4, keep_source); + SET_VECTOR_ELT(out, 5, keep_parse_data); + + UNPROTECT(9); + return out; +} + +SEXP C_impute_package_srcrefs(SEXP package, SEXP include_internal, SEXP verbose) { + if (TYPEOF(package) != STRSXP || Rf_xlength(package) != 1 || + STRING_ELT(package, 0) == NA_STRING || CHAR(STRING_ELT(package, 0))[0] == '\0') { + Rf_error("`package` must be a single non-empty package name"); + } + int incl = (TYPEOF(include_internal) == LGLSXP && Rf_xlength(include_internal) >= 1) + ? LOGICAL(include_internal)[0] : 1; + int verb = (TYPEOF(verbose) == LGLSXP && Rf_xlength(verbose) >= 1) + ? LOGICAL(verbose)[0] : 1; + + const char *pkg_name = CHAR(STRING_ELT(package, 0)); + SEXP env = PROTECT(load_namespace_(pkg_name)); + + SEXP nms = PROTECT(ls_env(env, incl)); + R_xlen_t nn = Rf_xlength(nms); + + SEXP fn_names = PROTECT(Rf_allocVector(STRSXP, nn)); + int nfn = 0; + for (R_xlen_t i = 0; i < nn; i++) { + const char *nm = CHAR(STRING_ELT(nms, i)); + if (!exists_in(nm, env)) continue; + SEXP obj = PROTECT(get_in(nm, env)); + if (Rf_isFunction(obj) && !is_primitive_(obj)) { + SET_STRING_ELT(fn_names, nfn++, STRING_ELT(nms, i)); + } + UNPROTECT(1); + } + SEXP fn_trim = PROTECT(Rf_allocVector(STRSXP, nfn)); + for (int i = 0; i < nfn; i++) SET_STRING_ELT(fn_trim, i, STRING_ELT(fn_names, i)); + SEXP final_names = PROTECT(sort_unique_strvec(fn_trim)); + + R_xlen_t fn_n = Rf_xlength(final_names); + SEXP failed = PROTECT(Rf_allocVector(STRSXP, fn_n)); + for (R_xlen_t i = 0; i < fn_n; i++) SET_STRING_ELT(failed, i, NA_STRING); + + int saved_quiet = imputesrcref_quiet; + imputesrcref_quiet = 1; + + for (R_xlen_t i = 0; i < fn_n; i++) { + const char *nm = CHAR(STRING_ELT(final_names, i)); + SEXP fn = PROTECT(get_in(nm, env)); + + char err_msg[2048]; + err_msg[0] = '\0'; + int err = 0; + SEXP patched = PROTECT(try_impute_srcrefs(fn, &err, err_msg, sizeof(err_msg))); + if (err) { + SET_STRING_ELT(failed, i, Rf_mkChar(err_msg[0] ? err_msg : "error")); + UNPROTECT(2); + continue; + } + + /* impute returned the input unchanged when neither srcref nor parse + data + deparse fallback were available — nothing to commit. */ + if (patched == fn) { + SET_STRING_ELT(failed, i, Rf_mkChar("no srcref")); + UNPROTECT(2); + continue; + } + + int locked = binding_is_locked(nm, env); + if (locked) unlock_binding_(nm, env); + assign_in(nm, patched, env); + if (locked) lock_binding_(nm, env); + + UNPROTECT(2); + } + + imputesrcref_quiet = saved_quiet; + + int patched_cnt = 0; + for (R_xlen_t i = 0; i < fn_n; i++) { + if (STRING_ELT(failed, i) == NA_STRING) patched_cnt++; + } + + SEXP report = PROTECT(Rf_allocVector(VECSXP, 4)); + SEXP rnms = PROTECT(Rf_allocVector(STRSXP, 4)); + SET_STRING_ELT(rnms, 0, Rf_mkChar("package")); + SET_STRING_ELT(rnms, 1, Rf_mkChar("fn_names")); + SET_STRING_ELT(rnms, 2, Rf_mkChar("failed")); + SET_STRING_ELT(rnms, 3, Rf_mkChar("patched_count")); + Rf_setAttrib(report, R_NamesSymbol, rnms); + SET_VECTOR_ELT(report, 0, package); + SET_VECTOR_ELT(report, 1, final_names); + SET_VECTOR_ELT(report, 2, failed); + SET_VECTOR_ELT(report, 3, Rf_ScalarInteger(patched_cnt)); + + if (verb) { + char msg[512]; + snprintf(msg, sizeof(msg), "Patched %d/%d function(s) in package `%s`.", + patched_cnt, (int) fn_n, pkg_name); + emit_message(msg); + } + + UNPROTECT(8); + return report; +} diff --git a/src/source_text.c b/src/source_text.c new file mode 100644 index 0000000..bbdede1 --- /dev/null +++ b/src/source_text.c @@ -0,0 +1,244 @@ +#include "imputesrcref.h" +#include + +int imputesrcref_quiet = 0; + +int imputesrcref_visual_col_to_byte_col(const char *line, int visual_col) { + int vis = 1; + int i; + int len = (int) strlen(line); + for (i = 0; i < len; i++) { + if (vis >= visual_col) return i + 1; + if (line[i] == '\t') { + vis = ((vis - 1) / 8 + 1) * 8 + 1; + } else { + vis++; + } + } + return len; +} + +static SEXP call_getSrcLines(SEXP srcfile, int start_line, int end_line) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("getSrcLines"), R_BaseEnv)); + SEXP a = PROTECT(Rf_ScalarInteger(start_line)); + SEXP b = PROTECT(Rf_ScalarInteger(end_line)); + SEXP call = PROTECT(Rf_lang4(fn, srcfile, a, b)); + SEXP res = R_tryEvalSilent(call, R_GlobalEnv, NULL); + UNPROTECT(4); + if (res == NULL) return R_NilValue; + return res; +} + +static SEXP call_srcfilecopy(const char *name, const char *txt) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("srcfilecopy"), R_BaseEnv)); + SEXP a = PROTECT(Rf_mkString(name)); + SEXP b = PROTECT(Rf_mkString(txt)); + SEXP call = PROTECT(Rf_lang3(fn, a, b)); + SEXP res = Rf_eval(call, R_GlobalEnv); + UNPROTECT(4); + return res; +} + +static SEXP call_deparse_500(SEXP x) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("deparse"), R_BaseEnv)); + SEXP w = PROTECT(Rf_ScalarInteger(500)); + SEXP call = PROTECT(Rf_lang3(fn, x, w)); + SET_TAG(CDDR(call), Rf_install("width.cutoff")); + SEXP res = Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); + return res; +} + +static int get_option_logical(const char *name, int dflt) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("getOption"), R_BaseEnv)); + SEXP a = PROTECT(Rf_mkString(name)); + SEXP b = PROTECT(Rf_ScalarLogical(dflt)); + SEXP call = PROTECT(Rf_lang3(fn, a, b)); + SEXP res = PROTECT(Rf_eval(call, R_GlobalEnv)); + int out = dflt; + if (TYPEOF(res) == LGLSXP && Rf_xlength(res) >= 1) { + int v = LOGICAL(res)[0]; + if (v != NA_LOGICAL) out = (v ? 1 : 0); + } + UNPROTECT(5); + return out; +} + +static void emit_message(const char *txt) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("message"), R_BaseEnv)); + SEXP a = PROTECT(Rf_mkString(txt)); + SEXP call = PROTECT(Rf_lang2(fn, a)); + Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); +} + +static SEXP paste_lines(SEXP lines) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("paste"), R_BaseEnv)); + SEXP sep = PROTECT(Rf_mkString("\n")); + SEXP call = PROTECT(Rf_lang3(fn, lines, sep)); + SET_TAG(CDDR(call), Rf_install("collapse")); + SEXP res = Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); + return res; +} + +SEXP imputesrcref_source_text(SEXP fn) { + SEXP sr = Rf_getAttrib(fn, Rf_install("srcref")); + + if (sr == R_NilValue) { + int allow = get_option_logical("imputesrcref.allow_deparse_fallback", 0); + if (!allow) { + /* `imputesrcref_quiet` only suppresses the per-function warning + during batch processing; it does NOT override the user's + deparse-fallback preference. If the user enabled fallback they + have already accepted that line numbers for no-srcref functions + may shift to deparsed-source coordinates. */ + if (!imputesrcref_quiet) { + emit_message( + "Function has no srcref metadata and deparse fallback is disabled; " + "no changes were made. Set " + "options(imputesrcref.allow_deparse_fallback = TRUE) to enable " + "deparse-based fallback."); + } + return R_NilValue; + } + SEXP dep = PROTECT(call_deparse_500(fn)); + SEXP collapsed = PROTECT(paste_lines(dep)); + const char *txt = CHAR(STRING_ELT(collapsed, 0)); + SEXP srcfile = PROTECT(call_srcfilecopy("", txt)); + + SEXP out = PROTECT(Rf_allocVector(VECSXP, 5)); + SEXP nms = PROTECT(Rf_allocVector(STRSXP, 5)); + SET_STRING_ELT(nms, 0, Rf_mkChar("text")); + SET_STRING_ELT(nms, 1, Rf_mkChar("srcfile")); + SET_STRING_ELT(nms, 2, Rf_mkChar("line_offset")); + SET_STRING_ELT(nms, 3, Rf_mkChar("first_col_offset")); + SET_STRING_ELT(nms, 4, Rf_mkChar("lines")); + Rf_setAttrib(out, R_NamesSymbol, nms); + SET_VECTOR_ELT(out, 0, collapsed); + SET_VECTOR_ELT(out, 1, srcfile); + SET_VECTOR_ELT(out, 2, Rf_ScalarInteger(0)); + SET_VECTOR_ELT(out, 3, Rf_ScalarInteger(0)); + /* Deparsed source lines: line_offset is 0, so absolute line k maps to + dep[k-1]. */ + SET_VECTOR_ELT(out, 4, dep); + UNPROTECT(5); + return out; + } + + SEXP srcfile = Rf_getAttrib(sr, Rf_install("srcfile")); + if (srcfile == R_NilValue) Rf_error("Function srcref is missing srcfile"); + + if (TYPEOF(sr) != INTSXP) { + sr = PROTECT(Rf_coerceVector(sr, INTSXP)); + } else { + PROTECT(sr); + } + + int *p = INTEGER(sr); + int n = (int) Rf_xlength(sr); + int candidates[3][4]; + int ncand = 0; + if (n >= 8) { + candidates[ncand][0] = p[6]; candidates[ncand][1] = p[7]; + candidates[ncand][2] = p[4]; candidates[ncand][3] = p[5]; ncand++; + } + if (n >= 6) { + candidates[ncand][0] = p[0]; candidates[ncand][1] = p[2]; + candidates[ncand][2] = p[4]; candidates[ncand][3] = p[5]; ncand++; + } + if (n >= 4) { + candidates[ncand][0] = p[0]; candidates[ncand][1] = p[2]; + candidates[ncand][2] = p[1]; candidates[ncand][3] = p[3]; ncand++; + } + + int chosen_start_line = 0, chosen_end_line = 0, chosen_start_col = 0, chosen_end_col = 0; + SEXP lines = R_NilValue; + + for (int ci = 0; ci < ncand; ci++) { + int sl = candidates[ci][0]; + int el = candidates[ci][1]; + int sc = candidates[ci][2]; + int ec = candidates[ci][3]; + if (sl == NA_INTEGER || el == NA_INTEGER || sc == NA_INTEGER || ec == NA_INTEGER) continue; + if (sl <= 0 || el <= 0 || sc <= 0 || ec <= 0) continue; + if (el < sl) continue; + if (el == sl && ec < sc) continue; + + SEXP attempt = call_getSrcLines(srcfile, sl, el); + if (attempt == R_NilValue || TYPEOF(attempt) != STRSXP || Rf_xlength(attempt) == 0) continue; + + chosen_start_line = sl; + chosen_end_line = el; + chosen_start_col = sc; + chosen_end_col = ec; + lines = attempt; + break; + } + + UNPROTECT(1); + + if (lines == R_NilValue) Rf_error("Could not read source lines for function"); + + PROTECT(lines); + R_xlen_t nlines = Rf_xlength(lines); + SEXP new_lines = PROTECT(Rf_duplicate(lines)); + if (nlines == 1) { + const char *l = CHAR(STRING_ELT(new_lines, 0)); + int byte_sc = imputesrcref_visual_col_to_byte_col(l, chosen_start_col); + int byte_ec = imputesrcref_visual_col_to_byte_col(l, chosen_end_col); + int len = (int) strlen(l); + if (byte_sc < 1) byte_sc = 1; + if (byte_ec > len) byte_ec = len; + int slen = byte_ec - byte_sc + 1; + if (slen < 0) slen = 0; + char *buf = (char*) R_alloc((size_t)(slen + 1), sizeof(char)); + if (slen > 0) memcpy(buf, l + byte_sc - 1, (size_t) slen); + buf[slen] = '\0'; + SET_STRING_ELT(new_lines, 0, Rf_mkChar(buf)); + } else { + const char *l0 = CHAR(STRING_ELT(new_lines, 0)); + int byte_sc = imputesrcref_visual_col_to_byte_col(l0, chosen_start_col); + int len0 = (int) strlen(l0); + if (byte_sc < 1) byte_sc = 1; + int slen0 = len0 - byte_sc + 1; + if (slen0 < 0) slen0 = 0; + char *buf0 = (char*) R_alloc((size_t)(slen0 + 1), sizeof(char)); + if (slen0 > 0) memcpy(buf0, l0 + byte_sc - 1, (size_t) slen0); + buf0[slen0] = '\0'; + SET_STRING_ELT(new_lines, 0, Rf_mkChar(buf0)); + + const char *ln = CHAR(STRING_ELT(new_lines, nlines - 1)); + int byte_ec = imputesrcref_visual_col_to_byte_col(ln, chosen_end_col); + int lenN = (int) strlen(ln); + if (byte_ec > lenN) byte_ec = lenN; + int slenN = byte_ec; + if (slenN < 0) slenN = 0; + char *bufN = (char*) R_alloc((size_t)(slenN + 1), sizeof(char)); + if (slenN > 0) memcpy(bufN, ln, (size_t) slenN); + bufN[slenN] = '\0'; + SET_STRING_ELT(new_lines, nlines - 1, Rf_mkChar(bufN)); + } + + SEXP collapsed = PROTECT(paste_lines(new_lines)); + + SEXP out = PROTECT(Rf_allocVector(VECSXP, 5)); + SEXP nms = PROTECT(Rf_allocVector(STRSXP, 5)); + SET_STRING_ELT(nms, 0, Rf_mkChar("text")); + SET_STRING_ELT(nms, 1, Rf_mkChar("srcfile")); + SET_STRING_ELT(nms, 2, Rf_mkChar("line_offset")); + SET_STRING_ELT(nms, 3, Rf_mkChar("first_col_offset")); + SET_STRING_ELT(nms, 4, Rf_mkChar("lines")); + Rf_setAttrib(out, R_NamesSymbol, nms); + SET_VECTOR_ELT(out, 0, collapsed); + SET_VECTOR_ELT(out, 1, srcfile); + SET_VECTOR_ELT(out, 2, Rf_ScalarInteger(chosen_start_line - 1)); + SET_VECTOR_ELT(out, 3, Rf_ScalarInteger(chosen_start_col - 1)); + /* Untrimmed source lines for [chosen_start_line, chosen_end_line]; used to + convert visual columns to byte offsets. Absolute line k maps to + lines[k - chosen_start_line]. */ + SET_VECTOR_ELT(out, 4, lines); + + UNPROTECT(5); + return out; +} diff --git a/src/srcref_sites.c b/src/srcref_sites.c new file mode 100644 index 0000000..069850c --- /dev/null +++ b/src/srcref_sites.c @@ -0,0 +1,565 @@ +#include "imputesrcref.h" +#include +#include +#include + +typedef struct { + char **strs; + int n; + int cap; +} strbuf; + +static void strbuf_init(strbuf *b) { b->strs = NULL; b->n = 0; b->cap = 0; } + +static void strbuf_push(strbuf *b, const char *s) { + if (b->n == b->cap) { + int new_cap = b->cap == 0 ? 16 : b->cap * 2; + char **new_strs = (char**) R_alloc((size_t) new_cap, sizeof(char*)); + if (b->strs && b->n > 0) memcpy(new_strs, b->strs, (size_t) b->n * sizeof(char*)); + b->strs = new_strs; + b->cap = new_cap; + } + size_t len = strlen(s); + char *copy = (char*) R_alloc(len + 1, sizeof(char)); + memcpy(copy, s, len + 1); + b->strs[b->n++] = copy; +} + +static SEXP strbuf_to_strsxp(const strbuf *b) { + SEXP out = PROTECT(Rf_allocVector(STRSXP, b->n)); + for (int i = 0; i < b->n; i++) SET_STRING_ELT(out, i, Rf_mkChar(b->strs[i])); + UNPROTECT(1); + return out; +} + +static SEXP base_fn(const char *name) { + return Rf_findFun(Rf_install(name), R_BaseEnv); +} + +/* Wrap a SEXP value in `quote(...)` so that when the surrounding call is + evaluated, the value is passed unchanged instead of being re-evaluated as + a symbol lookup or function call. */ +static SEXP quote_wrap(SEXP x) { + return Rf_lang2(Rf_install("quote"), x); +} + +static SEXP do_deparse_one_line(SEXP expr) { + SEXP dep_fn = PROTECT(base_fn("deparse")); + SEXP qx = PROTECT(quote_wrap(expr)); + SEXP w = PROTECT(Rf_ScalarInteger(500)); + SEXP call = PROTECT(Rf_lang3(dep_fn, qx, w)); + SET_TAG(CDDR(call), Rf_install("width.cutoff")); + SEXP lines = PROTECT(Rf_eval(call, R_GlobalEnv)); + + SEXP paste_fn = PROTECT(base_fn("paste")); + SEXP sep = PROTECT(Rf_mkString(" ")); + SEXP call2 = PROTECT(Rf_lang3(paste_fn, lines, sep)); + SET_TAG(CDDR(call2), Rf_install("collapse")); + SEXP txt = PROTECT(Rf_eval(call2, R_GlobalEnv)); + + SEXP gsub_fn = PROTECT(base_fn("gsub")); + SEXP pat = PROTECT(Rf_mkString("[[:space:]]+")); + SEXP rep = PROTECT(Rf_mkString(" ")); + SEXP call3 = PROTECT(Rf_lang4(gsub_fn, pat, rep, txt)); + SEXP result = Rf_eval(call3, R_GlobalEnv); + UNPROTECT(13); + return result; +} + +static void format_srcref_tuple(SEXP sr, char *buf, size_t buf_size) { + if (sr == R_NilValue || TYPEOF(sr) != INTSXP) { + snprintf(buf, buf_size, "NA"); + return; + } + R_xlen_t n = Rf_xlength(sr); + int *p = INTEGER(sr); + int pos = snprintf(buf, buf_size, "("); + for (R_xlen_t i = 0; i < n; i++) { + if (pos < 0 || (size_t) pos >= buf_size) break; + int w = snprintf(buf + pos, buf_size - pos, "%s%d", + i == 0 ? "" : ",", p[i]); + if (w < 0) break; + pos += w; + } + if (pos >= 0 && (size_t) pos < buf_size) { + snprintf(buf + pos, buf_size - pos, ")"); + } +} + +static SEXP do_srcref_to_text(SEXP sr) { + if (TYPEOF(sr) != INTSXP || Rf_xlength(sr) < 4) { + return Rf_ScalarString(NA_STRING); + } + SEXP srcfile = Rf_getAttrib(sr, Rf_install("srcfile")); + if (srcfile == R_NilValue) return Rf_ScalarString(NA_STRING); + + int *p = INTEGER(sr); + int sl = p[0], sc = p[1], el = p[2], ec = p[3]; + + SEXP gsl_fn = PROTECT(base_fn("getSrcLines")); + SEXP a = PROTECT(Rf_ScalarInteger(sl)); + SEXP b = PROTECT(Rf_ScalarInteger(el)); + SEXP call = PROTECT(Rf_lang4(gsl_fn, srcfile, a, b)); + int err = 0; + SEXP lines = PROTECT(R_tryEvalSilent(call, R_GlobalEnv, &err)); + if (err) { + UNPROTECT(5); + return Rf_ScalarString(NA_STRING); + } + R_xlen_t n = Rf_xlength(lines); + if (n == 0) { + UNPROTECT(5); + return Rf_ScalarString(NA_STRING); + } + + SEXP new_lines = PROTECT(Rf_duplicate(lines)); + /* sc/ec are byte offsets (srcref slots 2/4), per R's convention, so slice + directly. node_srcref emits proper byte offsets even for tab-indented + source. */ + if (n == 1) { + const char *l = CHAR(STRING_ELT(new_lines, 0)); + int len = (int) strlen(l); + int s = sc, e = ec; + if (s < 1) s = 1; + if (e > len) e = len; + int slen = e - s + 1; + if (slen < 0) slen = 0; + char *buf = (char*) R_alloc((size_t)(slen + 1), sizeof(char)); + if (slen > 0) memcpy(buf, l + s - 1, (size_t) slen); + buf[slen] = '\0'; + SET_STRING_ELT(new_lines, 0, Rf_mkChar(buf)); + } else { + const char *l0 = CHAR(STRING_ELT(new_lines, 0)); + int len0 = (int) strlen(l0); + int s = sc; + if (s < 1) s = 1; + int slen0 = len0 - s + 1; + if (slen0 < 0) slen0 = 0; + char *buf0 = (char*) R_alloc((size_t)(slen0 + 1), sizeof(char)); + if (slen0 > 0) memcpy(buf0, l0 + s - 1, (size_t) slen0); + buf0[slen0] = '\0'; + SET_STRING_ELT(new_lines, 0, Rf_mkChar(buf0)); + + const char *ln = CHAR(STRING_ELT(new_lines, n - 1)); + int lenN = (int) strlen(ln); + int e = ec; + if (e > lenN) e = lenN; + int slenN = e; + if (slenN < 0) slenN = 0; + char *bufN = (char*) R_alloc((size_t)(slenN + 1), sizeof(char)); + if (slenN > 0) memcpy(bufN, ln, (size_t) slenN); + bufN[slenN] = '\0'; + SET_STRING_ELT(new_lines, n - 1, Rf_mkChar(bufN)); + } + + SEXP paste_fn = PROTECT(base_fn("paste")); + SEXP nl = PROTECT(Rf_mkString("\n")); + SEXP call_p = PROTECT(Rf_lang3(paste_fn, new_lines, nl)); + SET_TAG(CDDR(call_p), Rf_install("collapse")); + SEXP r = Rf_eval(call_p, R_GlobalEnv); + UNPROTECT(9); + return r; +} + +static SEXP do_canonicalize_text(SEXP text) { + if (TYPEOF(text) != STRSXP || Rf_xlength(text) < 1) { + return Rf_ScalarString(NA_STRING); + } + if (STRING_ELT(text, 0) == NA_STRING) { + return Rf_ScalarString(NA_STRING); + } + SEXP parse_fn = PROTECT(base_fn("parse")); + SEXP keep = PROTECT(Rf_ScalarLogical(0)); + SEXP call = PROTECT(Rf_lang3(parse_fn, text, keep)); + SET_TAG(CDR(call), Rf_install("text")); + SET_TAG(CDDR(call), Rf_install("keep.source")); + int err = 0; + SEXP parsed = R_tryEvalSilent(call, R_GlobalEnv, &err); + if (err) { UNPROTECT(3); return Rf_ScalarString(NA_STRING); } + PROTECT(parsed); + if (Rf_xlength(parsed) != 1) { + UNPROTECT(4); + return Rf_ScalarString(NA_STRING); + } + SEXP single = VECTOR_ELT(parsed, 0); + SEXP res = do_deparse_one_line(single); + UNPROTECT(4); + return res; +} + +static SEXP do_transparent_srcref(SEXP node) { + SEXP sr = Rf_getAttrib(node, Rf_install("srcref")); + if (sr == R_NilValue) return R_NilValue; + SEXP sr_list; + int allocated_list = 0; + if (TYPEOF(sr) == VECSXP) { + sr_list = sr; + } else { + sr_list = PROTECT(Rf_allocVector(VECSXP, 1)); + SET_VECTOR_ELT(sr_list, 0, sr); + allocated_list = 1; + } + R_xlen_t n = Rf_xlength(sr_list); + if (n < 2) { + if (allocated_list) UNPROTECT(1); + return R_NilValue; + } + SEXP a = VECTOR_ELT(sr_list, 0); + SEXP b = VECTOR_ELT(sr_list, 1); + + SEXP id_fn = PROTECT(base_fn("identical")); + SEXP qa = PROTECT(quote_wrap(a)); + SEXP qb = PROTECT(quote_wrap(b)); + SEXP call = PROTECT(Rf_lang3(id_fn, qa, qb)); + SEXP r = Rf_eval(call, R_GlobalEnv); + int eq = TYPEOF(r) == LGLSXP && LOGICAL(r)[0] == TRUE; + UNPROTECT(4); + if (allocated_list) UNPROTECT(1); + return eq ? a : R_NilValue; +} + +static SEXP do_strip_transparent_braces(SEXP expr) { + if (TYPEOF(expr) != LANGSXP) return expr; + + if (imputesrcref_is_braced(expr)) { + SEXP cdr = CDR(expr); + if (cdr != R_NilValue) { + SEXP tr_sr = do_transparent_srcref(expr); + if (tr_sr != R_NilValue) { + return do_strip_transparent_braces(CAR(cdr)); + } + } + } + + int n = 0; + for (SEXP it = expr; it != R_NilValue; it = CDR(it)) n++; + + SEXP out = PROTECT(Rf_allocList(n)); + SET_TYPEOF(out, LANGSXP); + SEXP src = expr; + SEXP dst = out; + while (src != R_NilValue) { + SEXP new_v = PROTECT(do_strip_transparent_braces(CAR(src))); + SETCAR(dst, new_v); + SET_TAG(dst, TAG(src)); + UNPROTECT(1); + src = CDR(src); + dst = CDR(dst); + } + UNPROTECT(1); + return out; +} + +/* Path manipulation helpers --- writes into provided buffer and returns the + new length (excluding terminator). If the suffix would overflow, leaves + the buffer unchanged and returns the original length. */ +static int path_push(char *path, int path_len, int path_cap, const char *suffix) { + int slen = (int) strlen(suffix); + if (path_len + slen + 1 > path_cap) return path_len; + memcpy(path + path_len, suffix, (size_t) slen); + path[path_len + slen] = '\0'; + return path_len + slen; +} + +static void emit_line(strbuf *b, const char *path, const char *dep, + const char *sr1, const char *sr2) { + int needed = snprintf(NULL, 0, "path=%s node=%s sr1=%s sr2=%s", + path, dep, sr1, sr2); + if (needed < 0) return; + char *buf = (char*) R_alloc((size_t)(needed + 1), sizeof(char)); + snprintf(buf, (size_t)(needed + 1), "path=%s node=%s sr1=%s sr2=%s", + path, dep, sr1, sr2); + strbuf_push(b, buf); +} + +static void emit_check(strbuf *lines, strbuf *failures, int *checked, + const char *path, int ok, + const char *sr_text_encoded, + const char *expr_text_encoded) { + *checked = *checked + 1; + int needed = snprintf(NULL, 0, "check path=%s ok=%s sr_text=%s expr_text=%s", + path, ok ? "TRUE" : "FALSE", + sr_text_encoded, expr_text_encoded); + if (needed < 0) return; + char *buf = (char*) R_alloc((size_t)(needed + 1), sizeof(char)); + snprintf(buf, (size_t)(needed + 1), "check path=%s ok=%s sr_text=%s expr_text=%s", + path, ok ? "TRUE" : "FALSE", sr_text_encoded, expr_text_encoded); + strbuf_push(lines, buf); + if (!ok) strbuf_push(failures, path); +} + +static SEXP encode_string_quote(SEXP s_strsxp) { + SEXP fn = PROTECT(base_fn("encodeString")); + SEXP q = PROTECT(Rf_mkString("\"")); + SEXP call = PROTECT(Rf_lang3(fn, s_strsxp, q)); + SET_TAG(CDDR(call), Rf_install("quote")); + SEXP r = Rf_eval(call, R_GlobalEnv); + UNPROTECT(3); + return r; +} + +/* ---- collect_srcref_sites walker ---- */ +static void walk_sites(SEXP node, char *path, int path_len, int path_cap, strbuf *b) { + if (TYPEOF(node) == LANGSXP) { + if (imputesrcref_is_braced(node)) { + SEXP sr = Rf_getAttrib(node, Rf_install("srcref")); + if (sr != R_NilValue) { + SEXP dep = PROTECT(do_deparse_one_line(node)); + const char *dep_str = (TYPEOF(dep) == STRSXP && Rf_xlength(dep) >= 1) + ? CHAR(STRING_ELT(dep, 0)) : ""; + + char sr1_buf[256], sr2_buf[256]; + if (TYPEOF(sr) == VECSXP) { + R_xlen_t n = Rf_xlength(sr); + if (n >= 1) format_srcref_tuple(VECTOR_ELT(sr, 0), sr1_buf, sizeof(sr1_buf)); + else snprintf(sr1_buf, sizeof(sr1_buf), "NA"); + if (n >= 2) format_srcref_tuple(VECTOR_ELT(sr, 1), sr2_buf, sizeof(sr2_buf)); + else snprintf(sr2_buf, sizeof(sr2_buf), "NA"); + } else { + format_srcref_tuple(sr, sr1_buf, sizeof(sr1_buf)); + snprintf(sr2_buf, sizeof(sr2_buf), "NA"); + } + emit_line(b, path, dep_str, sr1_buf, sr2_buf); + UNPROTECT(1); + } + } + int i = 1; + for (SEXP it = node; it != R_NilValue; it = CDR(it), i++) { + char suffix[32]; + snprintf(suffix, sizeof(suffix), "/%d", i); + int new_len = path_push(path, path_len, path_cap, suffix); + walk_sites(CAR(it), path, new_len, path_cap, b); + path[path_len] = '\0'; + } + return; + } + if (TYPEOF(node) == EXPRSXP || TYPEOF(node) == VECSXP) { + R_xlen_t n = Rf_xlength(node); + for (R_xlen_t j = 0; j < n; j++) { + char suffix[32]; + snprintf(suffix, sizeof(suffix), "/%d", (int)(j + 1)); + int new_len = path_push(path, path_len, path_cap, suffix); + walk_sites(VECTOR_ELT(node, j), path, new_len, path_cap, b); + path[path_len] = '\0'; + } + return; + } + if (TYPEOF(node) == LISTSXP) { + int i = 1; + for (SEXP it = node; it != R_NilValue; it = CDR(it), i++) { + char suffix[32]; + snprintf(suffix, sizeof(suffix), "/%d", i); + int new_len = path_push(path, path_len, path_cap, suffix); + walk_sites(CAR(it), path, new_len, path_cap, b); + path[path_len] = '\0'; + } + } +} + +/* ---- collect_transparent_srcref_checks walker ---- */ +static void walk_checks(SEXP node, char *path, int path_len, int path_cap, + strbuf *lines, strbuf *failures, int *checked) { + if (TYPEOF(node) == LANGSXP) { + if (imputesrcref_is_braced(node)) { + SEXP tr_sr = do_transparent_srcref(node); + if (tr_sr != R_NilValue && CDR(node) != R_NilValue) { + PROTECT(tr_sr); + SEXP sr_text = PROTECT(do_srcref_to_text(tr_sr)); + SEXP sr_canon = PROTECT(do_canonicalize_text(sr_text)); + SEXP stripped = PROTECT(do_strip_transparent_braces(CADR(node))); + SEXP expr_text = PROTECT(do_deparse_one_line(stripped)); + + int ok = 0; + if (TYPEOF(sr_canon) == STRSXP && Rf_xlength(sr_canon) >= 1 && + STRING_ELT(sr_canon, 0) != NA_STRING && + TYPEOF(expr_text) == STRSXP && Rf_xlength(expr_text) >= 1) { + const char *a = CHAR(STRING_ELT(sr_canon, 0)); + const char *b = CHAR(STRING_ELT(expr_text, 0)); + ok = strcmp(a, b) == 0; + } + + SEXP sr_enc = PROTECT(encode_string_quote(sr_canon)); + SEXP exp_enc = PROTECT(encode_string_quote(expr_text)); + const char *sa = (TYPEOF(sr_enc) == STRSXP && Rf_xlength(sr_enc) >= 1) + ? CHAR(STRING_ELT(sr_enc, 0)) : "NA"; + const char *eb = (TYPEOF(exp_enc) == STRSXP && Rf_xlength(exp_enc) >= 1) + ? CHAR(STRING_ELT(exp_enc, 0)) : "NA"; + emit_check(lines, failures, checked, path, ok, sa, eb); + UNPROTECT(7); + } + } + int i = 1; + for (SEXP it = node; it != R_NilValue; it = CDR(it), i++) { + char suffix[32]; + snprintf(suffix, sizeof(suffix), "/%d", i); + int new_len = path_push(path, path_len, path_cap, suffix); + walk_checks(CAR(it), path, new_len, path_cap, lines, failures, checked); + path[path_len] = '\0'; + } + return; + } + if (TYPEOF(node) == EXPRSXP || TYPEOF(node) == VECSXP) { + R_xlen_t n = Rf_xlength(node); + for (R_xlen_t j = 0; j < n; j++) { + char suffix[32]; + snprintf(suffix, sizeof(suffix), "/%d", (int)(j + 1)); + int new_len = path_push(path, path_len, path_cap, suffix); + walk_checks(VECTOR_ELT(node, j), path, new_len, path_cap, lines, failures, checked); + path[path_len] = '\0'; + } + return; + } + if (TYPEOF(node) == LISTSXP) { + int i = 1; + for (SEXP it = node; it != R_NilValue; it = CDR(it), i++) { + char suffix[32]; + snprintf(suffix, sizeof(suffix), "/%d", i); + int new_len = path_push(path, path_len, path_cap, suffix); + walk_checks(CAR(it), path, new_len, path_cap, lines, failures, checked); + path[path_len] = '\0'; + } + } +} + +static SEXP call_formals(SEXP fn) { + SEXP f = PROTECT(base_fn("formals")); + SEXP call = PROTECT(Rf_lang2(f, fn)); + SEXP r = Rf_eval(call, R_GlobalEnv); + UNPROTECT(2); + return r; +} + +static SEXP call_body(SEXP fn) { + SEXP f = PROTECT(base_fn("body")); + SEXP call = PROTECT(Rf_lang2(f, fn)); + SEXP r = Rf_eval(call, R_GlobalEnv); + UNPROTECT(2); + return r; +} + +static int is_function_kind(SEXP x) { + return TYPEOF(x) == CLOSXP || TYPEOF(x) == BUILTINSXP || TYPEOF(x) == SPECIALSXP; +} + +/* Common helper: build path "formals/" for each formal with non-missing + default, or "body" for the body — calls the given walker on each. */ +typedef void (*walker_fn)(SEXP, char *, int, int, void*); + +static void walk_function_struct_sites(SEXP fn, char *path, int path_cap, strbuf *b) { + SEXP fmls = PROTECT(call_formals(fn)); + int idx = 1; + for (SEXP cell = fmls; cell != R_NilValue; cell = CDR(cell), idx++) { + SEXP val = CAR(cell); + if (val == R_MissingArg) continue; + SEXP tag = TAG(cell); + const char *nm; + char idx_str[32]; + if (tag != R_NilValue && TYPEOF(tag) == SYMSXP && + CHAR(PRINTNAME(tag))[0] != '\0') { + nm = CHAR(PRINTNAME(tag)); + } else { + snprintf(idx_str, sizeof(idx_str), "%d", idx); + nm = idx_str; + } + int plen = snprintf(path, path_cap, "formals/%s", nm); + if (plen < 0 || plen >= path_cap) plen = path_cap - 1; + walk_sites(val, path, plen, path_cap, b); + } + UNPROTECT(1); + int plen = snprintf(path, path_cap, "body"); + SEXP body = PROTECT(call_body(fn)); + walk_sites(body, path, plen, path_cap, b); + UNPROTECT(1); +} + +static void walk_function_struct_checks(SEXP fn, char *path, int path_cap, + strbuf *lines, strbuf *failures, int *checked) { + SEXP fmls = PROTECT(call_formals(fn)); + int idx = 1; + for (SEXP cell = fmls; cell != R_NilValue; cell = CDR(cell), idx++) { + SEXP val = CAR(cell); + if (val == R_MissingArg) continue; + SEXP tag = TAG(cell); + const char *nm; + char idx_str[32]; + if (tag != R_NilValue && TYPEOF(tag) == SYMSXP && + CHAR(PRINTNAME(tag))[0] != '\0') { + nm = CHAR(PRINTNAME(tag)); + } else { + snprintf(idx_str, sizeof(idx_str), "%d", idx); + nm = idx_str; + } + int plen = snprintf(path, path_cap, "formals/%s", nm); + if (plen < 0 || plen >= path_cap) plen = path_cap - 1; + walk_checks(val, path, plen, path_cap, lines, failures, checked); + } + UNPROTECT(1); + int plen = snprintf(path, path_cap, "body"); + SEXP body = PROTECT(call_body(fn)); + walk_checks(body, path, plen, path_cap, lines, failures, checked); + UNPROTECT(1); +} + +SEXP C_collect_srcref_sites(SEXP expr_or_fn) { + strbuf b; strbuf_init(&b); + enum { PATH_CAP = 8192 }; + char path[PATH_CAP]; + if (is_function_kind(expr_or_fn)) { + walk_function_struct_sites(expr_or_fn, path, PATH_CAP, &b); + } else { + int plen = snprintf(path, PATH_CAP, "root"); + walk_sites(expr_or_fn, path, plen, PATH_CAP, &b); + } + return strbuf_to_strsxp(&b); +} + +SEXP C_collect_transparent_srcref_checks(SEXP expr_or_fn) { + strbuf lines; strbuf_init(&lines); + strbuf failures; strbuf_init(&failures); + int checked = 0; + enum { PATH_CAP = 8192 }; + char path[PATH_CAP]; + if (is_function_kind(expr_or_fn)) { + walk_function_struct_checks(expr_or_fn, path, PATH_CAP, &lines, &failures, &checked); + } else { + int plen = snprintf(path, PATH_CAP, "root"); + walk_checks(expr_or_fn, path, plen, PATH_CAP, &lines, &failures, &checked); + } + + SEXP lines_sx = PROTECT(strbuf_to_strsxp(&lines)); + SEXP failures_sx = PROTECT(strbuf_to_strsxp(&failures)); + SEXP out = PROTECT(Rf_allocVector(VECSXP, 4)); + SEXP nms = PROTECT(Rf_allocVector(STRSXP, 4)); + SET_STRING_ELT(nms, 0, Rf_mkChar("checked")); + SET_STRING_ELT(nms, 1, Rf_mkChar("ok")); + SET_STRING_ELT(nms, 2, Rf_mkChar("failures")); + SET_STRING_ELT(nms, 3, Rf_mkChar("lines")); + Rf_setAttrib(out, R_NamesSymbol, nms); + SET_VECTOR_ELT(out, 0, Rf_ScalarInteger(checked)); + SET_VECTOR_ELT(out, 1, Rf_ScalarLogical(failures.n == 0)); + SET_VECTOR_ELT(out, 2, failures_sx); + SET_VECTOR_ELT(out, 3, lines_sx); + UNPROTECT(4); + return out; +} + +SEXP C_assert_transparent_srcref_consistency(SEXP expr_or_fn) { + SEXP checks = PROTECT(C_collect_transparent_srcref_checks(expr_or_fn)); + int ok = LOGICAL(VECTOR_ELT(checks, 1))[0]; + if (!ok) { + SEXP fails = VECTOR_ELT(checks, 2); + R_xlen_t nf = Rf_xlength(fails); + size_t total = 64; + for (R_xlen_t i = 0; i < nf; i++) total += strlen(CHAR(STRING_ELT(fails, i))) + 2; + char *buf = (char*) R_alloc(total, sizeof(char)); + int pos = snprintf(buf, total, "Transparent srcref text mismatch at: "); + for (R_xlen_t i = 0; i < nf; i++) { + if (i > 0) pos += snprintf(buf + pos, total - (size_t) pos, ", "); + pos += snprintf(buf + pos, total - (size_t) pos, "%s", CHAR(STRING_ELT(fails, i))); + } + UNPROTECT(1); + Rf_error("%s", buf); + } + UNPROTECT(1); + return checks; +} diff --git a/src/transform.c b/src/transform.c new file mode 100644 index 0000000..a6f6563 --- /dev/null +++ b/src/transform.c @@ -0,0 +1,698 @@ +#include "imputesrcref.h" +#include + +static SEXP cell_at(SEXP x, int i) { + while (i > 1 && x != R_NilValue) { + x = CDR(x); + i--; + } + return x; +} + +static int call_length_cons(SEXP x) { + int n = 0; + while (x != R_NilValue) { + n++; + x = CDR(x); + } + return n; +} + +static const char *call_op_name(SEXP expr) { + if (TYPEOF(expr) != LANGSXP) return ""; + SEXP h = CAR(expr); + if (TYPEOF(h) != SYMSXP) return ""; + return CHAR(PRINTNAME(h)); +} + +static int find_forcond_id(int node_id, parse_ctx *ctx) { + if (node_id < 0 || node_id > ctx->max_id) return -1; + int offs = ctx->all_children_offset[node_id]; + int cnt = ctx->all_children_count[node_id]; + for (int i = 0; i < cnt; i++) { + int row = ctx->all_children_data[offs + i]; + if (strcmp(CHAR(STRING_ELT(ctx->token, row)), "forcond") == 0) { + return ctx->id[row]; + } + } + return -1; +} + +static int first_expr_under(int parent_id, parse_ctx *ctx) { + if (parent_id < 0 || parent_id > ctx->max_id) return -1; + int cnt = ctx->expr_children_count[parent_id]; + if (cnt == 0) return -1; + int offs = ctx->expr_children_offset[parent_id]; + return ctx->id[ctx->expr_children_data[offs]]; +} + +static int node_has_token(int node_id, const char *token, parse_ctx *ctx) { + if (node_id < 0 || node_id > ctx->max_id) return 0; + int offs = ctx->all_children_offset[node_id]; + int cnt = ctx->all_children_count[node_id]; + for (int i = 0; i < cnt; i++) { + int row = ctx->all_children_data[offs + i]; + if (strcmp(CHAR(STRING_ELT(ctx->token, row)), token) == 0) return 1; + } + return 0; +} + +static int *expr_children_ids(int node_id, parse_ctx *ctx, int *out_count) { + if (node_id < 0 || node_id > ctx->max_id) { *out_count = 0; return NULL; } + int cnt = ctx->expr_children_count[node_id]; + int offs = ctx->expr_children_offset[node_id]; + int *arr = (int*) R_alloc((size_t)(cnt > 0 ? cnt : 1), sizeof(int)); + for (int i = 0; i < cnt; i++) { + arr[i] = ctx->id[ctx->expr_children_data[offs + i]]; + } + *out_count = cnt; + return arr; +} + +static int callee_blacklisted(SEXP arg, parse_ctx *ctx) { + if (TYPEOF(arg) != LANGSXP) return 0; + SEXP head = CAR(arg); + if (TYPEOF(head) != SYMSXP) return 0; + return imputesrcref_in_strvec(ctx->arg_wrap_blacklist, CHAR(PRINTNAME(head))); +} + +static SEXP recurse_and_maybe_wrap(SEXP value_expr, int child_id, parse_ctx *ctx, int wrap) { + PROTECT(value_expr); + SEXP transformed = PROTECT(imputesrcref_transform_expr(value_expr, child_id, ctx)); + int blacklisted = callee_blacklisted(value_expr, ctx); + SEXP result; + if (wrap && !imputesrcref_is_braced(transformed) && !blacklisted) { + SEXP sr = PROTECT(imputesrcref_node_srcref(child_id, ctx)); + result = imputesrcref_wrap_brace(transformed, sr); + UNPROTECT(1); + } else { + result = transformed; + } + UNPROTECT(2); + return result; +} + +typedef struct { + int *indices; + int *ids; + int n; + int valid; +} mapping_t; + +static mapping_t map_generic_indices(SEXP expr, int *child_ids, int n_ids, int drop_first) { + mapping_t m; + m.valid = 0; + m.indices = NULL; + m.ids = NULL; + m.n = 0; + + if (drop_first && n_ids > 0) { + child_ids++; + n_ids--; + } + + int n_parts = call_length_cons(expr); + + int *present = (int*) R_alloc((size_t) n_parts, sizeof(int)); + int n_present = 0; + SEXP it = expr; + for (int i = 1; i <= n_parts; i++, it = CDR(it)) { + if (!imputesrcref_is_missing_arg(CAR(it))) { + present[n_present++] = i; + } + } + + if (n_ids == n_present) { + m.indices = present; + m.n = n_present; + m.ids = child_ids; + m.valid = 1; + return m; + } + if (n_present >= 1 && n_ids == n_present - 1) { + m.indices = (int*) R_alloc((size_t)(n_present - 1), sizeof(int)); + memcpy(m.indices, present + 1, sizeof(int) * (size_t)(n_present - 1)); + m.n = n_present - 1; + m.ids = child_ids; + m.valid = 1; + return m; + } + if (n_ids == n_parts) { + int *idx = (int*) R_alloc((size_t) n_parts, sizeof(int)); + for (int i = 0; i < n_parts; i++) idx[i] = i + 1; + m.indices = idx; + m.n = n_parts; + m.ids = child_ids; + m.valid = 1; + return m; + } + if (n_ids == n_parts - 1 && n_parts >= 2) { + int *idx = (int*) R_alloc((size_t)(n_parts - 1), sizeof(int)); + for (int i = 0; i < n_parts - 1; i++) idx[i] = i + 2; + m.indices = idx; + m.n = n_parts - 1; + m.ids = child_ids; + m.valid = 1; + return m; + } + return m; +} + +static int is_logical_op_name(const char *op) { + return strcmp(op, "&&") == 0 || strcmp(op, "||") == 0 || + strcmp(op, "&") == 0 || strcmp(op, "|") == 0; +} + +static int is_assign_op_name(const char *op) { + return strcmp(op, "<-") == 0 || strcmp(op, "<<-") == 0 || + strcmp(op, "=") == 0 || strcmp(op, "->") == 0 || strcmp(op, "->>") == 0; +} + +SEXP imputesrcref_transform_expr(SEXP expr, int node_id, parse_ctx *ctx) { + if (TYPEOF(expr) != LANGSXP) return expr; + + SEXP out = PROTECT(Rf_duplicate(expr)); + + /* Already-injected transparent braces may not exist in the original parse + data. Recurse into the child with the same node_id. */ + if (imputesrcref_is_braced(out) && !node_has_token(node_id, "'{'", ctx)) { + int n = call_length_cons(out); + if (n >= 2) { + SEXP slot2 = cell_at(out, 2); + SEXP newval = PROTECT(imputesrcref_transform_expr(CAR(slot2), node_id, ctx)); + SETCAR(slot2, newval); + UNPROTECT(1); + } + UNPROTECT(1); + return out; + } + + const char *op = call_op_name(out); + int n_ids; + int *child_ids = expr_children_ids(node_id, ctx, &n_ids); + + if (strcmp(op, "function") == 0) { + SEXP fmls = CADR(out); + int cursor = 0; + + if (fmls != R_NilValue) { + SEXP cell = fmls; + while (cell != R_NilValue) { + SEXP val = CAR(cell); + /* Skip only true "missing" defaults: R_MissingArg (the empty + symbol). Legitimate NULL defaults (function(x = NULL)) still + appear as expr nodes in parse data and must advance the + cursor, otherwise subsequent defaults are mis-paired with + prior expr children. */ + if (val != R_MissingArg) { + if (cursor >= n_ids) Rf_error("Parse mapping mismatch for function formals"); + int cid = child_ids[cursor++]; + SEXP newv = PROTECT(imputesrcref_transform_expr(val, cid, ctx)); + if (!imputesrcref_is_braced(newv) && TYPEOF(newv) == LANGSXP) { + SEXP sr = PROTECT(imputesrcref_node_srcref(cid, ctx)); + newv = imputesrcref_wrap_brace(newv, sr); + UNPROTECT(1); + PROTECT(newv); + SETCAR(cell, newv); + UNPROTECT(2); + } else { + SETCAR(cell, newv); + UNPROTECT(1); + } + } + cell = CDR(cell); + } + } + + if (cursor >= n_ids) Rf_error("Parse mapping mismatch for function body"); + int body_id = child_ids[cursor]; + SEXP body_cell = cell_at(out, 3); + SEXP body_val = CAR(body_cell); + SEXP body_new = PROTECT(imputesrcref_transform_expr(body_val, body_id, ctx)); + if (!imputesrcref_is_braced(body_new) && TYPEOF(body_new) != LANGSXP) { + SEXP sr = PROTECT(imputesrcref_node_srcref(body_id, ctx)); + body_new = imputesrcref_wrap_brace(body_new, sr); + UNPROTECT(1); + PROTECT(body_new); + SETCAR(body_cell, body_new); + UNPROTECT(2); + } else { + SETCAR(body_cell, body_new); + UNPROTECT(1); + } + UNPROTECT(1); + return out; + } + + if (strcmp(op, "if") == 0) { + int n_parts = call_length_cons(out); + if (n_ids < 2) { + if (n_parts >= 2) { + SEXP c2 = cell_at(out, 2); + SEXP v = PROTECT(imputesrcref_transform_expr(CAR(c2), node_id, ctx)); + SETCAR(c2, v); + UNPROTECT(1); + } + if (n_parts >= 3) { + SEXP c3 = cell_at(out, 3); + SEXP v = PROTECT(imputesrcref_transform_expr(CAR(c3), node_id, ctx)); + SETCAR(c3, v); + UNPROTECT(1); + } + if (n_parts >= 4) { + SEXP c4 = cell_at(out, 4); + SEXP v = PROTECT(imputesrcref_transform_expr(CAR(c4), node_id, ctx)); + SETCAR(c4, v); + UNPROTECT(1); + } + UNPROTECT(1); + return out; + } + + /* condition */ + SEXP c2 = cell_at(out, 2); + SEXP cond_new = PROTECT(imputesrcref_transform_expr(CAR(c2), child_ids[0], ctx)); + if (!imputesrcref_is_braced(cond_new) && !imputesrcref_is_logical_op_call(cond_new)) { + SEXP sr = PROTECT(imputesrcref_node_srcref(child_ids[0], ctx)); + cond_new = imputesrcref_wrap_brace(cond_new, sr); + UNPROTECT(1); + PROTECT(cond_new); + SETCAR(c2, cond_new); + UNPROTECT(2); + } else { + SETCAR(c2, cond_new); + UNPROTECT(1); + } + + /* then */ + SEXP c3 = cell_at(out, 3); + SEXP then_v = recurse_and_maybe_wrap(CAR(c3), child_ids[1], ctx, 1); + PROTECT(then_v); + SETCAR(c3, then_v); + UNPROTECT(1); + + /* else */ + if (n_parts >= 4 && n_ids >= 3) { + SEXP c4 = cell_at(out, 4); + SEXP else_v = recurse_and_maybe_wrap(CAR(c4), child_ids[2], ctx, 1); + PROTECT(else_v); + SETCAR(c4, else_v); + UNPROTECT(1); + } + + UNPROTECT(1); + return out; + } + + if (strcmp(op, "while") == 0) { + if (n_ids < 2) Rf_error("Parse mapping mismatch for while expression"); + SEXP c2 = cell_at(out, 2); + SEXP cond_new = PROTECT(imputesrcref_transform_expr(CAR(c2), child_ids[0], ctx)); + if (!imputesrcref_is_braced(cond_new) && !imputesrcref_is_logical_op_call(cond_new)) { + SEXP sr = PROTECT(imputesrcref_node_srcref(child_ids[0], ctx)); + cond_new = imputesrcref_wrap_brace(cond_new, sr); + UNPROTECT(1); + PROTECT(cond_new); + SETCAR(c2, cond_new); + UNPROTECT(2); + } else { + SETCAR(c2, cond_new); + UNPROTECT(1); + } + SEXP c3 = cell_at(out, 3); + SEXP body_v = recurse_and_maybe_wrap(CAR(c3), child_ids[1], ctx, 1); + PROTECT(body_v); + SETCAR(c3, body_v); + UNPROTECT(1); + UNPROTECT(1); + return out; + } + + if (strcmp(op, "for") == 0) { + int forcond_id = find_forcond_id(node_id, ctx); + int seq_id = -1; + if (forcond_id >= 0) { + seq_id = first_expr_under(forcond_id, ctx); + } + + int body_start = 0; + if (n_ids > 0 && seq_id >= 0 && child_ids[0] == seq_id) { + body_start = 1; + } + + int body_ids_count = n_ids - body_start; + if (seq_id < 0 || body_ids_count < 1) { + Rf_error("Parse mapping mismatch for for expression"); + } + + SEXP c3 = cell_at(out, 3); + SEXP seq_v = recurse_and_maybe_wrap(CAR(c3), seq_id, ctx, 1); + PROTECT(seq_v); + SETCAR(c3, seq_v); + UNPROTECT(1); + + SEXP c4 = cell_at(out, 4); + SEXP body_v = recurse_and_maybe_wrap(CAR(c4), child_ids[body_start], ctx, 1); + PROTECT(body_v); + SETCAR(c4, body_v); + UNPROTECT(1); + + UNPROTECT(1); + return out; + } + + if (strcmp(op, "repeat") == 0) { + if (n_ids < 1) Rf_error("Parse mapping mismatch for repeat expression"); + SEXP c2 = cell_at(out, 2); + SEXP body_v = recurse_and_maybe_wrap(CAR(c2), child_ids[0], ctx, 1); + PROTECT(body_v); + SETCAR(c2, body_v); + UNPROTECT(1); + UNPROTECT(1); + return out; + } + + if (strcmp(op, "switch") == 0) { + int *ids = child_ids; + int n = n_ids; + if (n > 0) { ids++; n--; } + + int cursor = 0; + SEXP cell = CDR(out); + int parts_i = 2; + while (cell != R_NilValue) { + SEXP arg = CAR(cell); + if (!imputesrcref_is_missing_arg(arg)) { + if (cursor >= n) break; + int cid = ids[cursor++]; + SEXP v = recurse_and_maybe_wrap(arg, cid, ctx, 1); + PROTECT(v); + SETCAR(cell, v); + UNPROTECT(1); + } + cell = CDR(cell); + parts_i++; + } + (void) parts_i; + + UNPROTECT(1); + return out; + } + + if (is_logical_op_name(op)) { + int n_parts = call_length_cons(out); + if (n_ids < 2) { + if (n_ids == 1) { + SEXP c2 = cell_at(out, 2); + SEXP v = PROTECT(imputesrcref_transform_expr(CAR(c2), child_ids[0], ctx)); + SETCAR(c2, v); + UNPROTECT(1); + if (n_parts >= 3) { + SEXP c3 = cell_at(out, 3); + SEXP v3 = PROTECT(imputesrcref_transform_expr(CAR(c3), node_id, ctx)); + SETCAR(c3, v3); + UNPROTECT(1); + } + } else { + if (n_parts >= 2) { + SEXP c2 = cell_at(out, 2); + SEXP v = PROTECT(imputesrcref_transform_expr(CAR(c2), node_id, ctx)); + SETCAR(c2, v); + UNPROTECT(1); + } + if (n_parts >= 3) { + SEXP c3 = cell_at(out, 3); + SEXP v = PROTECT(imputesrcref_transform_expr(CAR(c3), node_id, ctx)); + SETCAR(c3, v); + UNPROTECT(1); + } + } + UNPROTECT(1); + return out; + } + SEXP c2 = cell_at(out, 2); + SEXP v2 = recurse_and_maybe_wrap(CAR(c2), child_ids[0], ctx, 1); + PROTECT(v2); + SETCAR(c2, v2); + UNPROTECT(1); + SEXP c3 = cell_at(out, 3); + SEXP v3 = recurse_and_maybe_wrap(CAR(c3), child_ids[1], ctx, 1); + PROTECT(v3); + SETCAR(c3, v3); + UNPROTECT(1); + UNPROTECT(1); + return out; + } + + /* Generic call. */ + mapping_t m = map_generic_indices(out, child_ids, n_ids, 0); + if (!m.valid) { + UNPROTECT(1); + return out; + } + + int op_blacklisted = (op[0] != '\0') && imputesrcref_in_strvec(ctx->arg_wrap_blacklist, op); + int wrap_generic_args = node_has_token(node_id, "'('", ctx) && + strcmp(op, "(") != 0 && + !op_blacklisted && + ctx->wrap_call_args; + + int is_assign_op = (op[0] != '\0') && is_assign_op_name(op); + int lhs_slot = (strcmp(op, "->") == 0 || strcmp(op, "->>") == 0) ? 3 : 2; + + for (int k = 0; k < m.n; k++) { + int i = m.indices[k]; + int cid = m.ids[k]; + SEXP cell = cell_at(out, i); + SEXP arg = CAR(cell); + if (imputesrcref_is_missing_arg(arg)) continue; + + int is_assign_lhs = is_assign_op && i == lhs_slot; + int saved_wrap = ctx->wrap_call_args; + if (is_assign_lhs && ctx->wrap_call_args) ctx->wrap_call_args = 0; + SEXP transformed = PROTECT(imputesrcref_transform_expr(arg, cid, ctx)); + if (is_assign_lhs && saved_wrap) ctx->wrap_call_args = saved_wrap; + + int slot_callee_bl = callee_blacklisted(arg, ctx); + int do_wrap = wrap_generic_args && i > 1 && !is_assign_lhs && + TYPEOF(arg) == LANGSXP && + !imputesrcref_is_braced(transformed) && + !imputesrcref_is_unquote_call(arg) && + !imputesrcref_is_call_named(arg, ":=") && + !imputesrcref_is_unary_arith_call(arg) && + !slot_callee_bl; + if (do_wrap) { + SEXP sr = PROTECT(imputesrcref_node_srcref(cid, ctx)); + transformed = imputesrcref_wrap_brace(transformed, sr); + UNPROTECT(1); + PROTECT(transformed); + SETCAR(cell, transformed); + UNPROTECT(2); + } else { + SETCAR(cell, transformed); + UNPROTECT(1); + } + } + + UNPROTECT(1); + return out; +} + +static SEXP call_parse(const char *text) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("parse"), R_BaseEnv)); + SEXP txt = PROTECT(Rf_mkString(text)); + SEXP keep = PROTECT(Rf_ScalarLogical(1)); + SEXP call = PROTECT(Rf_lang3(fn, txt, keep)); + SET_TAG(CDR(call), Rf_install("text")); + SET_TAG(CDDR(call), Rf_install("keep.source")); + int err = 0; + /* Use the silent variant: the first parse attempt is expected to fail for + functions defined inside a call (e.g. setMethod) whose extracted source + has `else` starting a line. The caller retries wrapped in `(...)`, so the + failure is normal control flow and must not be printed to stderr. + R_tryEval (non-silent) would emit the error via the C error handler, + which suppressMessages()/suppressWarnings() on the R side cannot catch. */ + SEXP res = R_tryEvalSilent(call, R_GlobalEnv, &err); + UNPROTECT(4); + if (err) return R_NilValue; + return res; +} + +static SEXP call_getParseData(SEXP parsed) { + SEXP fn = PROTECT(Rf_findFun(Rf_install("getParseData"), R_BaseNamespace)); + SEXP call = PROTECT(Rf_lang2(fn, parsed)); + int err = 0; + SEXP res = R_tryEvalSilent(call, R_GlobalEnv, &err); + UNPROTECT(2); + if (err) return R_NilValue; + return res; +} + +static SEXP call_formals(SEXP fn) { + SEXP f = PROTECT(Rf_findFun(Rf_install("formals"), R_BaseEnv)); + SEXP call = PROTECT(Rf_lang2(f, fn)); + SEXP res = Rf_eval(call, R_GlobalEnv); + UNPROTECT(2); + return res; +} + +static SEXP call_body(SEXP fn) { + SEXP f = PROTECT(Rf_findFun(Rf_install("body"), R_BaseEnv)); + SEXP call = PROTECT(Rf_lang2(f, fn)); + SEXP res = Rf_eval(call, R_GlobalEnv); + UNPROTECT(2); + return res; +} + +SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) { + if (TYPEOF(fn) != CLOSXP) { + Rf_error("`fn` must be a function"); + } + if (TYPEOF(wrap_call_args_sxp) != LGLSXP || Rf_xlength(wrap_call_args_sxp) != 1 || + LOGICAL(wrap_call_args_sxp)[0] == NA_LOGICAL) { + Rf_error("`wrap_call_args` must be TRUE or FALSE"); + } + if (TYPEOF(quiet_sxp) != LGLSXP || Rf_xlength(quiet_sxp) != 1 || + LOGICAL(quiet_sxp)[0] == NA_LOGICAL) { + Rf_error("`quiet` must be TRUE or FALSE"); + } + int wrap_call_args = LOGICAL(wrap_call_args_sxp)[0]; + int quiet = LOGICAL(quiet_sxp)[0]; + + SEXP fn_attrs = PROTECT(Rf_duplicate(ATTRIB(fn))); + + /* `quiet` only suppresses the "no srcref" message emitted by + source_text. OR with the ambient flag so a `quiet = TRUE` call inside an + already-quiet batch op never un-quiets it; restore immediately after. */ + int saved_quiet = imputesrcref_quiet; + if (quiet) imputesrcref_quiet = 1; + SEXP src = PROTECT(imputesrcref_source_text(fn)); + imputesrcref_quiet = saved_quiet; + if (src == R_NilValue) { + UNPROTECT(2); + return fn; + } + + SEXP text_sxp = VECTOR_ELT(src, 0); + SEXP srcfile = VECTOR_ELT(src, 1); + int line_offset = INTEGER(VECTOR_ELT(src, 2))[0]; + int first_col_offset = INTEGER(VECTOR_ELT(src, 3))[0]; + + const char *txt = CHAR(STRING_ELT(text_sxp, 0)); + SEXP parsed = PROTECT(call_parse(txt)); + int paren_wrapped = 0; + + if (parsed == R_NilValue) { + UNPROTECT(1); /* parsed (NilValue) */ + int len = (int) strlen(txt); + char *buf = (char*) R_alloc((size_t)(len + 3), sizeof(char)); + buf[0] = '('; + memcpy(buf + 1, txt, (size_t) len); + buf[len + 1] = ')'; + buf[len + 2] = '\0'; + parsed = PROTECT(call_parse(buf)); + if (parsed == R_NilValue) Rf_error("Could not parse function source"); + paren_wrapped = 1; + } + + SEXP pd = PROTECT(call_getParseData(parsed)); + if (pd == R_NilValue || TYPEOF(pd) != VECSXP) { + Rf_error("Could not obtain parse data for function"); + } + + /* find expr_rows / root id */ + SEXP nms = Rf_getAttrib(pd, R_NamesSymbol); + SEXP token_col = R_NilValue; + SEXP id_col = R_NilValue; + SEXP parent_col = R_NilValue; + R_xlen_t nc = Rf_xlength(nms); + for (R_xlen_t i = 0; i < nc; i++) { + const char *cn = CHAR(STRING_ELT(nms, i)); + if (strcmp(cn, "token") == 0) token_col = VECTOR_ELT(pd, i); + else if (strcmp(cn, "id") == 0) id_col = VECTOR_ELT(pd, i); + else if (strcmp(cn, "parent") == 0) parent_col = VECTOR_ELT(pd, i); + } + if (token_col == R_NilValue || id_col == R_NilValue || parent_col == R_NilValue) { + Rf_error("Parse data missing required columns"); + } + R_xlen_t pd_n = Rf_xlength(token_col); + if (pd_n == 0) Rf_error("Parse data does not contain expression nodes"); + + int *id_arr = INTEGER(id_col); + int *par_arr = INTEGER(parent_col); + + int root_id = -1; + int root_count = 0; + for (R_xlen_t i = 0; i < pd_n; i++) { + if (strcmp(CHAR(STRING_ELT(token_col, i)), "expr") == 0 && par_arr[i] == 0) { + root_id = id_arr[i]; + root_count++; + } + } + if (root_count != 1) { + Rf_error("Expected exactly one top-level expression for function source"); + } + + if (paren_wrapped) { + /* descend into inner expr child */ + int inner = -1; + int inner_count = 0; + for (R_xlen_t i = 0; i < pd_n; i++) { + if (strcmp(CHAR(STRING_ELT(token_col, i)), "expr") == 0 && par_arr[i] == root_id) { + inner = id_arr[i]; + inner_count++; + } + } + if (inner_count != 1) Rf_error("Expected exactly one expression inside paren wrapper"); + root_id = inner; + first_col_offset -= 1; + } + + SEXP blacklist = PROTECT(imputesrcref_effective_blacklist()); + + parse_ctx ctx; + imputesrcref_build_ctx(&ctx, pd, srcfile, line_offset, first_col_offset, blacklist, wrap_call_args); + + /* Source lines for visual->byte column conversion in node_srcref. Absolute + line k maps to lines[k - (line_offset + 1)]. */ + SEXP src_lines = VECTOR_ELT(src, 4); + if (TYPEOF(src_lines) == STRSXP) { + ctx.abs_lines = src_lines; + ctx.n_abs_lines = (int) Rf_xlength(src_lines); + ctx.abs_lines_start = line_offset + 1; + } + + /* Build fn_expr = call("function", formals(fn), body(fn)) */ + SEXP fmls = PROTECT(call_formals(fn)); + SEXP bdy = PROTECT(call_body(fn)); + SEXP fnsym = PROTECT(Rf_install("function")); + SEXP fn_expr = PROTECT(Rf_allocList(3)); + SET_TYPEOF(fn_expr, LANGSXP); + SETCAR(fn_expr, fnsym); + SETCAR(CDR(fn_expr), fmls); + SETCAR(CDDR(fn_expr), bdy); + + SEXP transformed = PROTECT(imputesrcref_transform_expr(fn_expr, root_id, &ctx)); + + /* Apply to fn: out <- fn; formals(out) <- transformed[[2]]; body(out) <- transformed[[3]] */ + SEXP out = PROTECT(Rf_duplicate(fn)); + SEXP new_formals = CADR(transformed); + SEXP new_body = CADDR(transformed); + + if (new_formals != R_NilValue) { + SET_FORMALS(out, new_formals); + } + SET_BODY(out, new_body); + + /* Reapply original attributes */ + SEXP attr_iter = fn_attrs; + while (attr_iter != R_NilValue) { + SEXP tag = TAG(attr_iter); + SEXP val = CAR(attr_iter); + Rf_setAttrib(out, tag, val); + attr_iter = CDR(attr_iter); + } + + UNPROTECT(11); + return out; +} diff --git a/tests/testthat/test-blacklist-api.R b/tests/testthat/test-blacklist-api.R index 9ff48d9..4cbc313 100644 --- a/tests/testthat/test-blacklist-api.R +++ b/tests/testthat/test-blacklist-api.R @@ -6,7 +6,7 @@ test_that("SPECIALSXP calls are blacklisted by default", { expect_true("quote" %in% imputesrcref::get_impute_blacklist(include_default = TRUE)) expect_identical(imputesrcref::get_impute_blacklist(include_default = FALSE), character()) - fn <- make_fn("function() quote(x + 1)") + fn <- make_fn("function() { quote(x + 1) }") out <- imputesrcref::impute_srcrefs(fn) sites <- imputesrcref:::collect_srcref_sites(out) @@ -19,7 +19,7 @@ test_that("user blacklist entries are applied and resettable", { on.exit(options(imputesrcref.wrap_arg_blacklist = old), add = TRUE) imputesrcref::reset_impute_blacklist() - fn <- make_fn("function(x) g(x + 1)") + fn <- make_fn("function(x) { g(x + 1) }") wrapped <- imputesrcref::impute_srcrefs(fn) wrapped_sites <- imputesrcref:::collect_srcref_sites(wrapped) expect_true(any(grepl("g\\(\\{ x \\+ 1 \\}\\)", wrapped_sites))) @@ -41,7 +41,7 @@ test_that("generic argument wrapping only applies to call expressions", { on.exit(options(imputesrcref.wrap_arg_blacklist = old), add = TRUE) imputesrcref::reset_impute_blacklist() - fn <- make_fn("function(x) g(x + 1, 1, x)") + fn <- make_fn("function(x) { g(x + 1, 1, x) }") out <- imputesrcref::impute_srcrefs(fn) sites <- imputesrcref:::collect_srcref_sites(out) @@ -55,7 +55,7 @@ test_that("wrap_call_args can disable generic argument wrapping", { on.exit(options(imputesrcref.wrap_arg_blacklist = old), add = TRUE) imputesrcref::reset_impute_blacklist() - fn <- make_fn("function(x) g(x + 1)") + fn <- make_fn("function(x) { g(x + 1) }") out <- imputesrcref::impute_srcrefs(fn, wrap_call_args = FALSE) sites <- imputesrcref:::collect_srcref_sites(out) diff --git a/tests/testthat/test-package-srcref-imputation.R b/tests/testthat/test-package-srcref-imputation.R index 2821c30..dabba8c 100644 --- a/tests/testthat/test-package-srcref-imputation.R +++ b/tests/testthat/test-package-srcref-imputation.R @@ -1,19 +1,111 @@ -test_that("ggplot2 full package srcref imputation is stable", { - skip_if_not( - identical(Sys.getenv("FULL_TEST", unset = ""), "1"), - "Set FULL_TEST=1 to run." - ) - skip_if_not_installed("ggplot2") - - res <- imputesrcref::impute_package_srcrefs("ggplot2", include_internal = TRUE, verbose = FALSE) - - fn_names <- res$fn_names - failed <- sum(!is.na(res$failed)) - patched <- res$patched_count - non_missing <- sum(!is.na(res$failed) & !grepl("missing parse data", res$failed, fixed = TRUE)) - - expect_gt(length(fn_names), 0L) - expect_gt(patched, 0L) - expect_lt(failed, length(fn_names)) - expect_equal(non_missing, 0L) -}) +# Whole-package srcref imputation over a corpus of popular packages. +# +# These are heavy integration tests: they patch every function in each +# package's namespace and verify correctness invariants. They require the +# packages to be installed with srcref retention (install from source with +# `--with-keep.source`), so they are gated behind FULL_TEST=1 and degrade +# gracefully when a package is absent or was installed without srcref. +# +# FULL_TEST=1 Rscript -e "testthat::test_dir('tests/testthat')" + +corpus_packages <- c( + "data.table", + "dplyr", + "fs", + "ggplot2", + "glue", + "jsonlite", + "stringr", + "zoo" +) + +# Reasons a function may legitimately be left unpatched. Anything else counts +# as a real failure that the test should surface. +skippable_failures <- c("missing parse data", "no srcref") + +# How many patched functions to deep-check per package (idempotence + srcref +# text consistency). Bounded so the suite stays reasonably fast on large +# namespaces such as ggplot2 / dplyr. +sample_size <- 40L + +for (pkg in corpus_packages) { + local({ + p <- pkg + + test_that(sprintf("whole-package srcref imputation is correct: %s", p), { + skip_if_not( + identical(Sys.getenv("FULL_TEST", unset = ""), "1"), + "Set FULL_TEST=1 to run." + ) + skip_if_not_installed(p) + + res <- imputesrcref::impute_package_srcrefs( + p, + include_internal = TRUE, + verbose = FALSE + ) + + expect_gt(length(res$fn_names), 0L) + + # Every inspected function must either patch cleanly or be skipped for a + # legitimate reason. A failure with any other message is a real bug. + real_failures <- res$failed[ + !is.na(res$failed) & !(res$failed %in% skippable_failures) + ] + expect_equal( + length(real_failures), + 0L, + info = sprintf( + "%s: unexpected failures: %s", + p, + paste(unique(real_failures), collapse = "; ") + ) + ) + + # If the package was installed without srcref retention there is nothing + # to patch; skip the per-function correctness checks rather than fail. + skip_if( + res$patched_count == 0L, + sprintf("%s installed without srcref retention; nothing patched", p) + ) + + # Deep-check a sample of patched functions. `impute_package_srcrefs` has + # already replaced the namespace bindings with their imputed versions, so + # `get()` returns the patched function. + ns <- loadNamespace(p) + patched_idx <- which(is.na(res$failed)) + sample_idx <- patched_idx[seq_len(min(sample_size, length(patched_idx)))] + + for (i in sample_idx) { + nm <- res$fn_names[[i]] + fn <- get(nm, envir = ns, inherits = FALSE) + if (!is.function(fn) || is.primitive(fn)) { + next + } + + # Re-imputation must be a no-op: the transform is idempotent. + again <- imputesrcref::impute_srcrefs(fn, quiet = TRUE) + expect_identical( + body(again), body(fn), + info = sprintf("%s::%s is not idempotent (body)", p, nm) + ) + expect_identical( + formals(again), formals(fn), + info = sprintf("%s::%s is not idempotent (formals)", p, nm) + ) + + # Every injected transparent brace must carry a srcref whose source + # text matches the wrapped expression. This is the line-accuracy + # guarantee: a wrong line/column would make the text mismatch. + checks <- imputesrcref:::collect_transparent_srcref_checks(fn) + expect_true( + isTRUE(checks$ok), + info = sprintf( + "%s::%s srcref text mismatch at: %s", + p, nm, paste(checks$failures, collapse = ", ") + ) + ) + } + }) + }) +} diff --git a/tests/testthat/test-srcref-imputation.out b/tests/testthat/test-srcref-imputation.out index 77b0c24..83a5927 100644 --- a/tests/testthat/test-srcref-imputation.out +++ b/tests/testthat/test-srcref-imputation.out @@ -14,25 +14,23 @@ check path=body/2/4 ok=TRUE sr_text="g()" expr_text="g()" === loops === idempotent=TRUE -transparent_checks=10 +transparent_checks=9 transparent_checks_ok=TRUE -path=body node={ for (i in { 1:3 }) { if ({ x } || { y }) { a() } else { b() } } while ({ x } & { y }) { c() } repeat { d() } } sr1=(1,16,1,16,16,16,1,1) sr2=(1,18,1,56,18,56,1,1) +path=body node={ for (i in { 1:3 }) if ({ x } || { y }) { a() } else { b() } while ({ x } & { y }) { c() } repeat { d() } } sr1=(1,16,1,16,16,16,1,1) sr2=(1,18,1,56,18,56,1,1) path=body/2/3 node={ 1:3 } sr1=(1,28,1,30,28,30,1,1) sr2=(1,28,1,30,28,30,1,1) -path=body/2/4 node={ if ({ x } || { y }) { a() } else { b() } } sr1=(1,33,1,56,33,56,1,1) sr2=(1,33,1,56,33,56,1,1) -path=body/2/4/2/2/2 node={ x } sr1=(1,37,1,37,37,37,1,1) sr2=(1,37,1,37,37,37,1,1) -path=body/2/4/2/2/3 node={ y } sr1=(1,42,1,42,42,42,1,1) sr2=(1,42,1,42,42,42,1,1) -path=body/2/4/2/3 node={ a() } sr1=(1,45,1,47,45,47,1,1) sr2=(1,45,1,47,45,47,1,1) -path=body/2/4/2/4 node={ b() } sr1=(1,54,1,56,54,56,1,1) sr2=(1,54,1,56,54,56,1,1) +path=body/2/4/2/2 node={ x } sr1=(1,37,1,37,37,37,1,1) sr2=(1,37,1,37,37,37,1,1) +path=body/2/4/2/3 node={ y } sr1=(1,42,1,42,42,42,1,1) sr2=(1,42,1,42,42,42,1,1) +path=body/2/4/3 node={ a() } sr1=(1,45,1,47,45,47,1,1) sr2=(1,45,1,47,45,47,1,1) +path=body/2/4/4 node={ b() } sr1=(1,54,1,56,54,56,1,1) sr2=(1,54,1,56,54,56,1,1) path=body/3/2/2 node={ x } sr1=(1,66,1,66,66,66,1,1) sr2=(1,66,1,66,66,66,1,1) path=body/3/2/3 node={ y } sr1=(1,70,1,70,70,70,1,1) sr2=(1,70,1,70,70,70,1,1) path=body/3/3 node={ c() } sr1=(1,73,1,75,73,75,1,1) sr2=(1,73,1,75,73,75,1,1) path=body/4/2 node={ d() } sr1=(1,85,1,87,85,87,1,1) sr2=(1,85,1,87,85,87,1,1) check path=body/2/3 ok=TRUE sr_text="1:3" expr_text="1:3" -check path=body/2/4 ok=TRUE sr_text="if (x || y) a() else b()" expr_text="if (x || y) a() else b()" -check path=body/2/4/2/2/2 ok=TRUE sr_text="x" expr_text="x" -check path=body/2/4/2/2/3 ok=TRUE sr_text="y" expr_text="y" -check path=body/2/4/2/3 ok=TRUE sr_text="a()" expr_text="a()" -check path=body/2/4/2/4 ok=TRUE sr_text="b()" expr_text="b()" +check path=body/2/4/2/2 ok=TRUE sr_text="x" expr_text="x" +check path=body/2/4/2/3 ok=TRUE sr_text="y" expr_text="y" +check path=body/2/4/3 ok=TRUE sr_text="a()" expr_text="a()" +check path=body/2/4/4 ok=TRUE sr_text="b()" expr_text="b()" check path=body/3/2/2 ok=TRUE sr_text="x" expr_text="x" check path=body/3/2/3 ok=TRUE sr_text="y" expr_text="y" check path=body/3/3 ok=TRUE sr_text="c()" expr_text="c()" @@ -52,7 +50,7 @@ check path=body/2/4 ok=TRUE sr_text="g()" expr_text="g()" === defaults-and-unbraced-body === idempotent=TRUE -transparent_checks=11 +transparent_checks=10 transparent_checks_ok=TRUE path=formals/a node={ { x } && { y } } sr1=(1,14,1,19,14,19,1,1) sr2=(1,14,1,19,14,19,1,1) path=formals/a/2/2 node={ x } sr1=(1,14,1,14,14,14,1,1) sr2=(1,14,1,14,14,14,1,1) @@ -61,10 +59,9 @@ path=formals/b node={ if ({ p }) { u } else { v } } sr1=(1,26,1,40,26,40,1,1) sr path=formals/b/2/2 node={ p } sr1=(1,30,1,30,30,30,1,1) sr2=(1,30,1,30,30,30,1,1) path=formals/b/2/3 node={ u } sr1=(1,33,1,33,33,33,1,1) sr2=(1,33,1,33,33,33,1,1) path=formals/b/2/4 node={ v } sr1=(1,40,1,40,40,40,1,1) sr2=(1,40,1,40,40,40,1,1) -path=body node={ if ({ a }) { m() } else { n() } } sr1=(1,43,1,61,43,61,1,1) sr2=(1,43,1,61,43,61,1,1) -path=body/2/2 node={ a } sr1=(1,47,1,47,47,47,1,1) sr2=(1,47,1,47,47,47,1,1) -path=body/2/3 node={ m() } sr1=(1,50,1,52,50,52,1,1) sr2=(1,50,1,52,50,52,1,1) -path=body/2/4 node={ n() } sr1=(1,59,1,61,59,61,1,1) sr2=(1,59,1,61,59,61,1,1) +path=body/2 node={ a } sr1=(1,47,1,47,47,47,1,1) sr2=(1,47,1,47,47,47,1,1) +path=body/3 node={ m() } sr1=(1,50,1,52,50,52,1,1) sr2=(1,50,1,52,50,52,1,1) +path=body/4 node={ n() } sr1=(1,59,1,61,59,61,1,1) sr2=(1,59,1,61,59,61,1,1) check path=formals/a ok=TRUE sr_text="x && y" expr_text="x && y" check path=formals/a/2/2 ok=TRUE sr_text="x" expr_text="x" check path=formals/a/2/3 ok=TRUE sr_text="y" expr_text="y" @@ -72,10 +69,9 @@ check path=formals/b ok=TRUE sr_text="if (p) u else v" expr_text="if (p) u else check path=formals/b/2/2 ok=TRUE sr_text="p" expr_text="p" check path=formals/b/2/3 ok=TRUE sr_text="u" expr_text="u" check path=formals/b/2/4 ok=TRUE sr_text="v" expr_text="v" -check path=body ok=TRUE sr_text="if (a) m() else n()" expr_text="if (a) m() else n()" -check path=body/2/2 ok=TRUE sr_text="a" expr_text="a" -check path=body/2/3 ok=TRUE sr_text="m()" expr_text="m()" -check path=body/2/4 ok=TRUE sr_text="n()" expr_text="n()" +check path=body/2 ok=TRUE sr_text="a" expr_text="a" +check path=body/3 ok=TRUE sr_text="m()" expr_text="m()" +check path=body/4 ok=TRUE sr_text="n()" expr_text="n()" === already-braced === idempotent=TRUE @@ -89,123 +85,97 @@ path=body/2/4 node={ g() } sr1=(1,45,1,45,45,45,1,1) sr2=(1,46,1,48,46,48,1,1) === null-args-preserved === idempotent=TRUE -transparent_checks=8 +transparent_checks=6 transparent_checks_ok=TRUE -path=body node={ f(NULL, { if ({ x }) { y } else { z } }, NULL, { if ({ p }) { q } else { r } }, NULL) } sr1=(1,12,1,12,12,12,1,1) sr2=(1,14,1,66,14,66,1,1) -path=body/2/3 node={ if ({ x }) { y } else { z } } sr1=(1,22,1,36,22,36,1,1) sr2=(1,22,1,36,22,36,1,1) -path=body/2/3/2/2 node={ x } sr1=(1,26,1,26,26,26,1,1) sr2=(1,26,1,26,26,26,1,1) -path=body/2/3/2/3 node={ y } sr1=(1,29,1,29,29,29,1,1) sr2=(1,29,1,29,29,29,1,1) -path=body/2/3/2/4 node={ z } sr1=(1,36,1,36,36,36,1,1) sr2=(1,36,1,36,36,36,1,1) -path=body/2/5 node={ if ({ p }) { q } else { r } } sr1=(1,45,1,59,45,59,1,1) sr2=(1,45,1,59,45,59,1,1) -path=body/2/5/2/2 node={ p } sr1=(1,49,1,49,49,49,1,1) sr2=(1,49,1,49,49,49,1,1) -path=body/2/5/2/3 node={ q } sr1=(1,52,1,52,52,52,1,1) sr2=(1,52,1,52,52,52,1,1) -path=body/2/5/2/4 node={ r } sr1=(1,59,1,59,59,59,1,1) sr2=(1,59,1,59,59,59,1,1) -check path=body/2/3 ok=TRUE sr_text="if (x) y else z" expr_text="if (x) y else z" -check path=body/2/3/2/2 ok=TRUE sr_text="x" expr_text="x" -check path=body/2/3/2/3 ok=TRUE sr_text="y" expr_text="y" -check path=body/2/3/2/4 ok=TRUE sr_text="z" expr_text="z" -check path=body/2/5 ok=TRUE sr_text="if (p) q else r" expr_text="if (p) q else r" -check path=body/2/5/2/2 ok=TRUE sr_text="p" expr_text="p" -check path=body/2/5/2/3 ok=TRUE sr_text="q" expr_text="q" -check path=body/2/5/2/4 ok=TRUE sr_text="r" expr_text="r" +path=body node={ f(NULL, if ({ x }) { y } else { z }, NULL, if ({ p }) { q } else { r }, NULL) } sr1=(1,12,1,12,12,12,1,1) sr2=(1,14,1,66,14,66,1,1) +path=body/2/3/2 node={ x } sr1=(1,26,1,26,26,26,1,1) sr2=(1,26,1,26,26,26,1,1) +path=body/2/3/3 node={ y } sr1=(1,29,1,29,29,29,1,1) sr2=(1,29,1,29,29,29,1,1) +path=body/2/3/4 node={ z } sr1=(1,36,1,36,36,36,1,1) sr2=(1,36,1,36,36,36,1,1) +path=body/2/5/2 node={ p } sr1=(1,49,1,49,49,49,1,1) sr2=(1,49,1,49,49,49,1,1) +path=body/2/5/3 node={ q } sr1=(1,52,1,52,52,52,1,1) sr2=(1,52,1,52,52,52,1,1) +path=body/2/5/4 node={ r } sr1=(1,59,1,59,59,59,1,1) sr2=(1,59,1,59,59,59,1,1) +check path=body/2/3/2 ok=TRUE sr_text="x" expr_text="x" +check path=body/2/3/3 ok=TRUE sr_text="y" expr_text="y" +check path=body/2/3/4 ok=TRUE sr_text="z" expr_text="z" +check path=body/2/5/2 ok=TRUE sr_text="p" expr_text="p" +check path=body/2/5/3 ok=TRUE sr_text="q" expr_text="q" +check path=body/2/5/4 ok=TRUE sr_text="r" expr_text="r" === generic-call-args === idempotent=TRUE -transparent_checks=4 +transparent_checks=3 transparent_checks_ok=TRUE -path=body node={ g({ x + 1 }, { f({ y + 1 }) }) } sr1=(1,16,1,29,16,29,1,1) sr2=(1,16,1,29,16,29,1,1) -path=body/2/2 node={ x + 1 } sr1=(1,18,1,20,18,20,1,1) sr2=(1,18,1,20,18,20,1,1) -path=body/2/3 node={ f({ y + 1 }) } sr1=(1,23,1,28,23,28,1,1) sr2=(1,23,1,28,23,28,1,1) -path=body/2/3/2/2 node={ y + 1 } sr1=(1,25,1,27,25,27,1,1) sr2=(1,25,1,27,25,27,1,1) -check path=body ok=TRUE sr_text="g(x + 1, f(y + 1))" expr_text="g(x + 1, f(y + 1))" -check path=body/2/2 ok=TRUE sr_text="x + 1" expr_text="x + 1" -check path=body/2/3 ok=TRUE sr_text="f(y + 1)" expr_text="f(y + 1)" -check path=body/2/3/2/2 ok=TRUE sr_text="y + 1" expr_text="y + 1" +path=body/2 node={ x + 1 } sr1=(1,18,1,20,18,20,1,1) sr2=(1,18,1,20,18,20,1,1) +path=body/3 node={ f({ y + 1 }) } sr1=(1,23,1,28,23,28,1,1) sr2=(1,23,1,28,23,28,1,1) +path=body/3/2/2 node={ y + 1 } sr1=(1,25,1,27,25,27,1,1) sr2=(1,25,1,27,25,27,1,1) +check path=body/2 ok=TRUE sr_text="x + 1" expr_text="x + 1" +check path=body/3 ok=TRUE sr_text="f(y + 1)" expr_text="f(y + 1)" +check path=body/3/2/2 ok=TRUE sr_text="y + 1" expr_text="y + 1" === missing-call-arg === idempotent=TRUE -transparent_checks=1 +transparent_checks=0 transparent_checks_ok=TRUE -path=body node={ quote(expr = ) } sr1=(1,12,1,25,12,25,1,1) sr2=(1,12,1,25,12,25,1,1) -check path=body ok=TRUE sr_text="quote(expr = )" expr_text="quote(expr = )" === source-file === count=2 functions=f1,f2 f1_parse_rows=65 f2_parse_rows=65 -f1_transparent_checks=5 -f2_transparent_checks=6 +f1_transparent_checks=4 +f2_transparent_checks=5 f1_transparent_ok=TRUE f2_transparent_ok=TRUE -path=body node={ if ({ x } && { y }) { f() } else { g() } } sr1=(1,22,1,45,22,45,1,1) sr2=(1,22,1,45,22,45,1,1) -path=body/2/2/2 node={ x } sr1=(1,26,1,26,26,26,1,1) sr2=(1,26,1,26,26,26,1,1) -path=body/2/2/3 node={ y } sr1=(1,31,1,31,31,31,1,1) sr2=(1,31,1,31,31,31,1,1) -path=body/2/3 node={ f() } sr1=(1,34,1,36,34,36,1,1) sr2=(1,34,1,36,34,36,1,1) -path=body/2/4 node={ g() } sr1=(1,43,1,45,43,45,1,1) sr2=(1,43,1,45,43,45,1,1) -check path=body ok=TRUE sr_text="if (x && y) f() else g()" expr_text="if (x && y) f() else g()" -check path=body/2/2/2 ok=TRUE sr_text="x" expr_text="x" -check path=body/2/2/3 ok=TRUE sr_text="y" expr_text="y" -check path=body/2/3 ok=TRUE sr_text="f()" expr_text="f()" -check path=body/2/4 ok=TRUE sr_text="g()" expr_text="g()" +path=body/2/2 node={ x } sr1=(1,26,1,26,26,26,1,1) sr2=(1,26,1,26,26,26,1,1) +path=body/2/3 node={ y } sr1=(1,31,1,31,31,31,1,1) sr2=(1,31,1,31,31,31,1,1) +path=body/3 node={ f() } sr1=(1,34,1,36,34,36,1,1) sr2=(1,34,1,36,34,36,1,1) +path=body/4 node={ g() } sr1=(1,43,1,45,43,45,1,1) sr2=(1,43,1,45,43,45,1,1) +check path=body/2/2 ok=TRUE sr_text="x" expr_text="x" +check path=body/2/3 ok=TRUE sr_text="y" expr_text="y" +check path=body/3 ok=TRUE sr_text="f()" expr_text="f()" +check path=body/4 ok=TRUE sr_text="g()" expr_text="g()" path=formals/a node={ { p } || { q } } sr1=(2,20,2,25,20,25,2,2) sr2=(2,20,2,25,20,25,2,2) path=formals/a/2/2 node={ p } sr1=(2,20,2,20,20,20,2,2) sr2=(2,20,2,20,20,20,2,2) path=formals/a/2/3 node={ q } sr1=(2,25,2,25,25,25,2,2) sr2=(2,25,2,25,25,25,2,2) -path=body node={ while ({ a }) { h() } } sr1=(2,28,2,40,28,40,2,2) sr2=(2,28,2,40,28,40,2,2) -path=body/2/2 node={ a } sr1=(2,35,2,35,35,35,2,2) sr2=(2,35,2,35,35,35,2,2) -path=body/2/3 node={ h() } sr1=(2,38,2,40,38,40,2,2) sr2=(2,38,2,40,38,40,2,2) +path=body/2 node={ a } sr1=(2,35,2,35,35,35,2,2) sr2=(2,35,2,35,35,35,2,2) +path=body/3 node={ h() } sr1=(2,38,2,40,38,40,2,2) sr2=(2,38,2,40,38,40,2,2) check path=formals/a ok=TRUE sr_text="p || q" expr_text="p || q" check path=formals/a/2/2 ok=TRUE sr_text="p" expr_text="p" check path=formals/a/2/3 ok=TRUE sr_text="q" expr_text="q" -check path=body ok=TRUE sr_text="while (a) h()" expr_text="while (a) h()" -check path=body/2/2 ok=TRUE sr_text="a" expr_text="a" -check path=body/2/3 ok=TRUE sr_text="h()" expr_text="h()" +check path=body/2 ok=TRUE sr_text="a" expr_text="a" +check path=body/3 ok=TRUE sr_text="h()" expr_text="h()" === package-like-srcref === sr_slots_1_3=100-100 sr_slots_7_8=3-3 -transparent_checks=5 +transparent_checks=4 transparent_checks_ok=TRUE -path=body node={ if ({ x } && { y }) { f() } else { g() } } sr1=(3,21,3,44,21,44,3,3) sr2=(3,21,3,44,21,44,3,3) -path=body/2/2/2 node={ x } sr1=(3,25,3,25,25,25,3,3) sr2=(3,25,3,25,25,25,3,3) -path=body/2/2/3 node={ y } sr1=(3,30,3,30,30,30,3,3) sr2=(3,30,3,30,30,30,3,3) -path=body/2/3 node={ f() } sr1=(3,33,3,35,33,35,3,3) sr2=(3,33,3,35,33,35,3,3) -path=body/2/4 node={ g() } sr1=(3,42,3,44,42,44,3,3) sr2=(3,42,3,44,42,44,3,3) -check path=body ok=TRUE sr_text="if (x && y) f() else g()" expr_text="if (x && y) f() else g()" -check path=body/2/2/2 ok=TRUE sr_text="x" expr_text="x" -check path=body/2/2/3 ok=TRUE sr_text="y" expr_text="y" -check path=body/2/3 ok=TRUE sr_text="f()" expr_text="f()" -check path=body/2/4 ok=TRUE sr_text="g()" expr_text="g()" +path=body/2/2 node={ x } sr1=(3,25,3,25,25,25,3,3) sr2=(3,25,3,25,25,25,3,3) +path=body/2/3 node={ y } sr1=(3,30,3,30,30,30,3,3) sr2=(3,30,3,30,30,30,3,3) +path=body/3 node={ f() } sr1=(3,33,3,35,33,35,3,3) sr2=(3,33,3,35,33,35,3,3) +path=body/4 node={ g() } sr1=(3,42,3,44,42,44,3,3) sr2=(3,42,3,44,42,44,3,3) +check path=body/2/2 ok=TRUE sr_text="x" expr_text="x" +check path=body/2/3 ok=TRUE sr_text="y" expr_text="y" +check path=body/3 ok=TRUE sr_text="f()" expr_text="f()" +check path=body/4 ok=TRUE sr_text="g()" expr_text="g()" === zero-formals === formals_is_null=TRUE idempotent=TRUE -transparent_checks=4 +transparent_checks=3 transparent_checks_ok=TRUE -path=body node={ if ({ TRUE }) { f() } else { g() } } sr1=(1,12,1,33,12,33,1,1) sr2=(1,12,1,33,12,33,1,1) -path=body/2/2 node={ TRUE } sr1=(1,16,1,19,16,19,1,1) sr2=(1,16,1,19,16,19,1,1) -path=body/2/3 node={ f() } sr1=(1,22,1,24,22,24,1,1) sr2=(1,22,1,24,22,24,1,1) -path=body/2/4 node={ g() } sr1=(1,31,1,33,31,33,1,1) sr2=(1,31,1,33,31,33,1,1) -check path=body ok=TRUE sr_text="if (TRUE) f() else g()" expr_text="if (TRUE) f() else g()" -check path=body/2/2 ok=TRUE sr_text="TRUE" expr_text="TRUE" -check path=body/2/3 ok=TRUE sr_text="f()" expr_text="f()" -check path=body/2/4 ok=TRUE sr_text="g()" expr_text="g()" +path=body/2 node={ TRUE } sr1=(1,16,1,19,16,19,1,1) sr2=(1,16,1,19,16,19,1,1) +path=body/3 node={ f() } sr1=(1,22,1,24,22,24,1,1) sr2=(1,22,1,24,22,24,1,1) +path=body/4 node={ g() } sr1=(1,31,1,33,31,33,1,1) sr2=(1,31,1,33,31,33,1,1) +check path=body/2 ok=TRUE sr_text="TRUE" expr_text="TRUE" +check path=body/3 ok=TRUE sr_text="f()" expr_text="f()" +check path=body/4 ok=TRUE sr_text="g()" expr_text="g()" === package-base === patched_count=0 === no-srcref-fallback === -default_blocked=TRUE -fallback_checks=5 +default_blocked=FALSE +fallback_checks=0 fallback_ok=TRUE -path=body node={ if ({ x } && { y }) { f() } else { g() } } sr1=(2,1,2,24,1,24,2,2) sr2=(2,1,2,24,1,24,2,2) -path=body/2/2/2 node={ x } sr1=(2,5,2,5,5,5,2,2) sr2=(2,5,2,5,5,5,2,2) -path=body/2/2/3 node={ y } sr1=(2,10,2,10,10,10,2,2) sr2=(2,10,2,10,10,10,2,2) -path=body/2/3 node={ f() } sr1=(2,13,2,15,13,15,2,2) sr2=(2,13,2,15,13,15,2,2) -path=body/2/4 node={ g() } sr1=(2,22,2,24,22,24,2,2) sr2=(2,22,2,24,22,24,2,2) -check path=body ok=TRUE sr_text="if (x && y) f() else g()" expr_text="if (x && y) f() else g()" -check path=body/2/2/2 ok=TRUE sr_text="x" expr_text="x" -check path=body/2/2/3 ok=TRUE sr_text="y" expr_text="y" -check path=body/2/3 ok=TRUE sr_text="f()" expr_text="f()" -check path=body/2/4 ok=TRUE sr_text="g()" expr_text="g()" diff --git a/tests/testthat/test-tab-columns.R b/tests/testthat/test-tab-columns.R new file mode 100644 index 0000000..cdff5ea --- /dev/null +++ b/tests/testthat/test-tab-columns.R @@ -0,0 +1,80 @@ +# Regression tests for tab-indented source. getParseData() reports visual +# (tab-expanded) columns, but R srcref byte slots (2 and 4) must hold byte +# offsets so that as.character.srcref() / getSrcref() (used by deparse and +# covr) extract the correct text. node_srcref converts visual -> byte. + +make_fn <- function(code) { + eval(parse(text = code, keep.source = TRUE)[[1L]], envir = new.env(parent = baseenv())) +} + +# Collect (srcref, wrapped-expression) pairs for every injected transparent +# brace in a function body. +brace_pairs <- function(fn) { + out <- list() + walk <- function(node) { + if (is.call(node)) { + if (is.symbol(node[[1L]]) && identical(as.character(node[[1L]]), "{") && + length(node) >= 2L) { + sr <- attr(node, "srcref", exact = TRUE) + if (!is.null(sr)) { + sr_list <- if (is.list(sr)) sr else list(sr) + if (length(sr_list) >= 2L && identical(sr_list[[1L]], sr_list[[2L]])) { + out[[length(out) + 1L]] <<- list( + sr = sr_list[[1L]], + expr = node[[2L]] + ) + } + } + } + for (i in seq_along(node)) walk(node[[i]]) + } + } + walk(body(fn)) + out +} + +test_that("tab-indented source yields byte-accurate srcref slots", { + # Tab + spaces before the call, so visual columns differ from byte columns. + code <- "function(e1, e2) {\n\t out <- zoo(e, index(e2), attr(e2, \"f\"))\n\tout\n}" + fn <- make_fn(code) + g <- imputesrcref::impute_srcrefs(fn) + + pairs <- brace_pairs(g) + expect_gt(length(pairs), 0L) + + for (pr in pairs) { + sr <- pr$sr + # Byte slots (2,4) must differ from visual slots (5,6) on the tab line for + # at least the deeper calls; more importantly, R's own extractor must + # return the wrapped expression verbatim. + extracted <- paste(as.character(sr), collapse = "\n") + expected <- paste(deparse(pr$expr), collapse = "\n") + expect_identical( + extracted, expected, + info = sprintf("srcref slots %s", paste(as.integer(sr), collapse = ",")) + ) + } +}) + +test_that("at least one tab-line brace has byte slot < visual slot", { + code <- "function(x) {\n\t\tg(h(x))\n}" + fn <- make_fn(code) + g <- imputesrcref::impute_srcrefs(fn) + pairs <- brace_pairs(g) + expect_gt(length(pairs), 0L) + + # The two leading tabs make visual column (slot 5) strictly greater than the + # byte column (slot 2) for content on that line. + has_offset <- any(vapply(pairs, function(pr) pr$sr[[2L]] < pr$sr[[5L]], logical(1))) + expect_true(has_offset) +}) + +test_that("space-indented source keeps byte slots equal to visual slots", { + code <- "function(x, y) if (x && y) f() else g()" + fn <- make_fn(code) + g <- imputesrcref::impute_srcrefs(fn) + for (pr in brace_pairs(g)) { + expect_identical(pr$sr[[2L]], pr$sr[[5L]]) + expect_identical(pr$sr[[4L]], pr$sr[[6L]]) + } +})