From ef0b7fbd0773e316fed6153f6d7e6623f4a665cf Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Fri, 15 Dec 2023 07:49:04 +0100 Subject: [PATCH 01/11] [hack]: Force file-level for all linters --- R/lint.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/lint.R b/R/lint.R index e7915d8561..224884a7a2 100644 --- a/R/lint.R +++ b/R/lint.R @@ -77,9 +77,13 @@ lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = if (!is_tainted(source_expressions$lines)) { for (expr in source_expressions$expressions) { if (is_lint_level(expr, "expression")) { - necessary_linters <- expression_linter_names + necessary_linters <- character() } else { - necessary_linters <- file_linter_names + necessary_linters <- names(linters) + + expr$lines <- expr$file_lines + expr$xml_parsed_content <- expr$full_xml_parsed_content + expr$parsed_content <- expr$full_parsed_content } for (linter in necessary_linters) { # use withCallingHandlers for friendlier failures on unexpected linter errors From b1258fb8090782e039d50562aefd704a4924bc18 Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Fri, 15 Dec 2023 23:25:34 +0100 Subject: [PATCH 02/11] add skeleton implementation --- R/is_lint_level.R | 13 +++++ R/lint.R | 136 ++++++++++++++++++++++++++++++++++++++++------ R/source_utils.R | 11 +++- 3 files changed, 141 insertions(+), 19 deletions(-) diff --git a/R/is_lint_level.R b/R/is_lint_level.R index d850c51cf0..422fded838 100644 --- a/R/is_lint_level.R +++ b/R/is_lint_level.R @@ -43,3 +43,16 @@ is_linter_level <- function(linter, level = c("expression", "file")) { level <- match.arg(level) identical(linter_level, level) } + +#' Determine whether an expression-level linter can handle multiple expressions at once +#' +#' Used by [lint()] to efficiently batch calls to expression-level linters. +#' +#' @param linter A linter. +#' +#' @keywords internal +#' @noRd +linter_supports_exprlist <- function(linter) { + linter_exprlist <- attr(linter, "linter_exprlist", exact = TRUE) + isTRUE(linter_exprlist) +} diff --git a/R/lint.R b/R/lint.R index 224884a7a2..bf19b195f7 100644 --- a/R/lint.R +++ b/R/lint.R @@ -72,28 +72,94 @@ lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = file_linter_names <- names(linters)[vapply(linters, is_linter_level, logical(1L), "file")] expression_linter_names <- names(linters)[vapply(linters, is_linter_level, logical(1L), "expression")] + supports_exprlist <- vapply(linters[expression_linter_names], linter_supports_exprlist, logical(1L)) lints <- list() if (!is_tainted(source_expressions$lines)) { - for (expr in source_expressions$expressions) { - if (is_lint_level(expr, "expression")) { - necessary_linters <- character() - } else { - necessary_linters <- names(linters) - - expr$lines <- expr$file_lines - expr$xml_parsed_content <- expr$full_xml_parsed_content - expr$parsed_content <- expr$full_parsed_content - } - for (linter in necessary_linters) { - # use withCallingHandlers for friendlier failures on unexpected linter errors - lints[[length(lints) + 1L]] <- withCallingHandlers( - get_lints(expr, linter, linters[[linter]], lint_cache, source_expressions$lines), + exprs_expression <- head(source_expressions$expressions, -1L) + expr_file <- source_expressions$expressions[[length(source_expressions$expressions)]] + + # Compute execution plan + file_linter_cached <- vapply(file_linter_names, has_lint, + expr = expr_file, cache = lint_cache, + FUN.VALUE = logical(1L)) + + # For expression level linters, each column is a linter, each row an expr + expr_linter_cached <- vapply(expression_linter_names, function(linter_name) { + vapply(exprs_expression, has_lint, linter = linter_name, cache = lint_cache, FUN.VALUE = logical(1L)) + }, FUN.VALUE = logical(length(exprs_expression))) + # Ensure 2D array even for just a single expr or linter + dim(expr_linter_cached) <- c(length(exprs_expression), length(expression_linter_names)) + colnames(expr_linter_cached) <- expression_linter_names + + # Retrieve cached lints where available + if (any(file_linter_cached)) { + lints[[length(lints) + 1L]] <- lapply(file_linter_names[file_linter_cached], function(linter_name) { + retrieve_lint(cache = lint_cache, expr = expr_file, linter = linter_name, lines = source_expressions$lines) + }) + } + + if (any(expr_linter_cached)) { + lints[[length(lints) + 1L]] <- lapply( + # only retrieve lints of linters with at least one cache hit + expression_linter_names[colSums(expr_linter_cached) > 0L], + function(linter_name) { + lapply(exprs_expression[expr_linter_cached[, linter_name]], function(expr) { + retrieve_lint(cache = lint_cache, expr = expr, linter = linter_name, lines = source_expressions$lines) + }) + } + ) + } + + # Compute file-level lints where cache missed + if (!all(file_linter_cached)) { + lints[[length(lints) + 1L]] <- lapply(file_linter_names[!file_linter_cached], function(linter_name) { + withCallingHandlers( + get_lints(expr_file, linter_name, linters[[linter_name]], lint_cache, source_expressions$lines), error = function(cond) { - stop("Linter '", linter, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) + stop("Linter '", linter_name, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) } ) - } + }) + } + + if (!all(expr_linter_cached)) { + # Compute individual expr-lints where exprlist batching is not supported + needs_running <- colSums(expr_linter_cached) < length(exprs_expression) + lints[[length(lints) + 1L]] <- lapply( + expression_linter_names[needs_running & !supports_exprlist], + function(linter_name) { + lapply(exprs_expression[!expr_linter_cached[, linter_name]], function(expr) { + withCallingHandlers( + get_lints(expr, linter_name, linters[[linter_name]], lint_cache, source_expressions$lines), + error = function(cond) { + stop("Linter '", linter_name, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) + } + ) + }) + } + ) + + lints[[length(lints) + 1L]] <- lapply( + expression_linter_names[needs_running & supports_exprlist], + function(linter_name) { + linter_fun <- linters[[linter_name]] + exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] + + # run on exprlist + exprlist_to_lint <- collapse_exprs(exprs_to_lint) + expr_lints <- flatten_lints(linter_fun(exprlist_to_lint)) + + for (i in seq_along(expr_lints)) { + expr_lints[[i]]$linter <- linter + } + + # write results to expr-level cache + + + expr_lints + } + ) } } @@ -712,3 +778,41 @@ zap_temp_filename <- function(res, needs_tempfile) { } res } + +#' Collapse a list of expression-level source expressions to an exprlist-level source expression +#' +#' @param expr_list A list containing expression-level source expressions +#' +#' @value An exprlist-level source expression +#' +#' @keywords internal +#' @noRd +collapse_exprs <- function(expr_list) { + if (length(expr_list) == 0L) { + return(list()) + } + xml_pc <- xml2::xml_new_root("exprlist") + function_call_cache <- list() + filename <- expr_list[[1L]]$filename + lines <- character() + parsed_content <- NULL + content <- "" + + for (expr in expr_list) { + xml2::xml_add_child(xml_pc, expr$xml_parsed_content) + function_call_cache <- c(function_call_cache, expr$xml_find_function_calls(NULL, keep_names = TRUE)) + lines <- c(lines, expr$lines) + parsed_content <- if (is.null(parsed_content)) expr$parsed_content else rbind(parsed_content, expr$parsed_content) + content <- paste(content, expr$content, sep = "\n") + } + xml_find_function_calls <- build_xml_find_function_calls(xml_pc, cache = function_call_cache) + + list( + filename = filename, + lines = lines, + parsed_content = parsed_content, + xml_parsed_content = xml_pc, + xml_find_function_calls = xml_find_function_calls, + content = content + ) +} \ No newline at end of file diff --git a/R/source_utils.R b/R/source_utils.R index 3179847afd..cfef05527f 100644 --- a/R/source_utils.R +++ b/R/source_utils.R @@ -1,6 +1,7 @@ #' Build the `xml_find_function_calls()` helper for a source expression #' #' @param xml The XML parse tree as an XML object (`xml_parsed_content` or `full_xml_parsed_content`) +#' @param cache Optional precomputed call cache. If present, no XPath queries will be run. #' #' @return A fast function to query #' `xml_find_all(xml, glue::glue("//SYMBOL_FUNCTION_CALL[text() = '{function_names[1]}' or ...]"))`, @@ -8,9 +9,13 @@ #' `xml_find_all(xml, glue::glue("//SYMBOL_FUNCTION_CALL[{ xp_text_in_table(function_names) }]"))`. #' #' @noRd -build_xml_find_function_calls <- function(xml) { - function_call_cache <- xml_find_all(xml, "//SYMBOL_FUNCTION_CALL") - names(function_call_cache) <- get_r_string(function_call_cache) +build_xml_find_function_calls <- function(xml, cache = NULL) { + if (is.null(cache)) { + function_call_cache <- xml_find_all(xml, "//SYMBOL_FUNCTION_CALL") + names(function_call_cache) <- get_r_string(function_call_cache) + } else { + function_call_cache <- cache + } function(function_names, keep_names = FALSE) { if (is.null(function_names)) { From 6bf2d5a029d3381beca310f6838d9d3a4b1617e8 Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 00:37:30 +0100 Subject: [PATCH 03/11] enable batched linting for all expression-level linters --- R/T_and_F_symbol_linter.R | 2 +- R/any_duplicated_linter.R | 2 +- R/any_is_na_linter.R | 2 +- R/assignment_linter.R | 2 +- R/backport_linter.R | 2 +- R/boolean_arithmetic_linter.R | 2 +- R/brace_linter.R | 2 +- R/class_equals_linter.R | 2 +- R/commas_linter.R | 2 +- R/comparison_negation_linter.R | 2 +- R/condition_call_linter.R | 2 +- R/condition_message_linter.R | 2 +- R/cyclocomp_linter.R | 2 +- R/equals_na_linter.R | 2 +- R/expect_comparison_linter.R | 2 +- R/expect_identical_linter.R | 2 +- R/expect_length_linter.R | 2 +- R/expect_named_linter.R | 2 +- R/expect_null_linter.R | 2 +- R/expect_s3_class_linter.R | 2 +- R/expect_s4_class_linter.R | 2 +- R/expect_true_false_linter.R | 2 +- R/expect_type_linter.R | 2 +- R/fixed_regex_linter.R | 2 +- R/function_argument_linter.R | 2 +- R/function_left_parentheses_linter.R | 2 +- R/if_not_else_linter.R | 2 +- R/if_switch_linter.R | 2 +- R/ifelse_censor_linter.R | 2 +- R/infix_spaces_linter.R | 2 +- R/inner_combine_linter.R | 2 +- R/is_numeric_linter.R | 2 +- R/keyword_quote_linter.R | 2 +- R/length_test_linter.R | 2 +- R/lint.R | 259 ++++++++++++++++----------- R/lintr-deprecated.R | 2 +- R/list_comparison_linter.R | 2 +- R/literal_coercion_linter.R | 2 +- R/matrix_apply_linter.R | 2 +- R/nested_ifelse_linter.R | 2 +- R/nested_pipe_linter.R | 2 +- R/nzchar_linter.R | 2 +- R/object_overwrite_linter.R | 2 +- R/one_call_pipe_linter.R | 2 +- R/outer_negation_linter.R | 2 +- R/paste_linter.R | 2 +- R/path_utils.R | 2 +- R/pipe_call_linter.R | 2 +- R/quotes_linter.R | 2 +- R/redundant_equals_linter.R | 2 +- R/redundant_ifelse_linter.R | 2 +- R/regex_subset_linter.R | 2 +- R/repeat_linter.R | 2 +- R/return_linter.R | 2 +- R/sample_int_linter.R | 2 +- R/scalar_in_linter.R | 2 +- R/seq_linter.R | 2 +- R/sort_linter.R | 2 +- R/string_boundary_linter.R | 2 +- R/system_file_linter.R | 2 +- R/todo_comment_linter.R | 2 +- R/undesirable_function_linter.R | 2 +- R/undesirable_operator_linter.R | 2 +- R/unnecessary_concatenation_linter.R | 2 +- R/unnecessary_lambda_linter.R | 2 +- R/unnecessary_nesting_linter.R | 2 +- R/unnecessary_placeholder_linter.R | 2 +- R/unreachable_code_linter.R | 2 +- R/utils.R | 6 +- R/vector_logic_linter.R | 2 +- R/yoda_test_linter.R | 2 +- 71 files changed, 233 insertions(+), 170 deletions(-) diff --git a/R/T_and_F_symbol_linter.R b/R/T_and_F_symbol_linter.R index b6c1300c7c..4879a97589 100644 --- a/R/T_and_F_symbol_linter.R +++ b/R/T_and_F_symbol_linter.R @@ -44,7 +44,7 @@ T_and_F_symbol_linter <- function() { # nolint: object_name. replacement_map <- c(T = "TRUE", F = "FALSE") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_usage <- xml_find_all(xml, usage_xpath) diff --git a/R/any_duplicated_linter.R b/R/any_duplicated_linter.R index 04a80bd84c..bc43a6055b 100644 --- a/R/any_duplicated_linter.R +++ b/R/any_duplicated_linter.R @@ -84,7 +84,7 @@ any_duplicated_linter <- function() { uses_nrow_xpath <- "./parent::expr/expr/expr[1]/SYMBOL_FUNCTION_CALL[text() = 'nrow']" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content xml_calls <- source_expression$xml_find_function_calls("any") diff --git a/R/any_is_na_linter.R b/R/any_is_na_linter.R index a0ea91e33c..4a915449a6 100644 --- a/R/any_is_na_linter.R +++ b/R/any_is_na_linter.R @@ -45,7 +45,7 @@ any_is_na_linter <- function() { ] " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("any") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/assignment_linter.R b/R/assignment_linter.R index da42b51194..fafc89cae9 100644 --- a/R/assignment_linter.R +++ b/R/assignment_linter.R @@ -99,7 +99,7 @@ assignment_linter <- function(allow_cascading_assign = TRUE, if (!allow_pipe_assign) "//SPECIAL[text() = '%<>%']" )) - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/backport_linter.R b/R/backport_linter.R index 3c1eaeaebf..83590ed013 100644 --- a/R/backport_linter.R +++ b/R/backport_linter.R @@ -45,7 +45,7 @@ backport_linter <- function(r_version = getRversion(), except = character()) { backport_index <- rep(names(backport_blacklist), times = lengths(backport_blacklist)) names(backport_index) <- unlist(backport_blacklist) - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content used_symbols <- xml_find_all(xml, "//SYMBOL") diff --git a/R/boolean_arithmetic_linter.R b/R/boolean_arithmetic_linter.R index c0d0c755c1..e29cc8c750 100644 --- a/R/boolean_arithmetic_linter.R +++ b/R/boolean_arithmetic_linter.R @@ -52,7 +52,7 @@ boolean_arithmetic_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { length_calls <- source_expression$xml_find_function_calls(c("which", "grep")) sum_calls <- source_expression$xml_find_function_calls("sum") any_expr <- c( diff --git a/R/brace_linter.R b/R/brace_linter.R index eebdb90ecf..7281409f90 100644 --- a/R/brace_linter.R +++ b/R/brace_linter.R @@ -146,7 +146,7 @@ brace_linter <- function(allow_single_line = FALSE) { ] " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content lints <- list() diff --git a/R/class_equals_linter.R b/R/class_equals_linter.R index 2dd24b83dd..a9656269b5 100644 --- a/R/class_equals_linter.R +++ b/R/class_equals_linter.R @@ -43,7 +43,7 @@ class_equals_linter <- function() { ] " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("class") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/commas_linter.R b/R/commas_linter.R index aeaf42878c..cfd3946fe6 100644 --- a/R/commas_linter.R +++ b/R/commas_linter.R @@ -77,7 +77,7 @@ commas_linter <- function(allow_trailing = FALSE) { "]" ) - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content before_lints <- xml_nodes_to_lints( diff --git a/R/comparison_negation_linter.R b/R/comparison_negation_linter.R index f2c3424abb..7f8116d13d 100644 --- a/R/comparison_negation_linter.R +++ b/R/comparison_negation_linter.R @@ -60,7 +60,7 @@ comparison_negation_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/condition_call_linter.R b/R/condition_call_linter.R index 8b13c8a921..bd777d12a1 100644 --- a/R/condition_call_linter.R +++ b/R/condition_call_linter.R @@ -79,7 +79,7 @@ condition_call_linter <- function(display_call = FALSE) { xpath <- glue::glue("parent::expr[{call_cond}]/parent::expr") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(c("stop", "warning")) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/condition_message_linter.R b/R/condition_message_linter.R index e20e53b4b1..baa9142405 100644 --- a/R/condition_message_linter.R +++ b/R/condition_message_linter.R @@ -55,7 +55,7 @@ condition_message_linter <- function() { /parent::expr ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(translators) bad_expr <- xml_find_all(xml_calls, xpath) sep_value <- get_r_string(bad_expr, xpath = "./expr/SYMBOL_SUB[text() = 'sep']/following-sibling::expr/STR_CONST") diff --git a/R/cyclocomp_linter.R b/R/cyclocomp_linter.R index c5563646f2..0c103f188a 100644 --- a/R/cyclocomp_linter.R +++ b/R/cyclocomp_linter.R @@ -22,7 +22,7 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export cyclocomp_linter <- function(complexity_limit = 15L) { - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { complexity <- try_silently( cyclocomp::cyclocomp(parse(text = source_expression$content)) ) diff --git a/R/equals_na_linter.R b/R/equals_na_linter.R index 2961ac9845..0c05f65a6b 100644 --- a/R/equals_na_linter.R +++ b/R/equals_na_linter.R @@ -46,7 +46,7 @@ equals_na_linter <- function() { /parent::expr ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/expect_comparison_linter.R b/R/expect_comparison_linter.R index 87dc24169a..af15a9893f 100644 --- a/R/expect_comparison_linter.R +++ b/R/expect_comparison_linter.R @@ -62,7 +62,7 @@ expect_comparison_linter <- function() { `==` = "expect_identical" ) - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("expect_true") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/expect_identical_linter.R b/R/expect_identical_linter.R index 4ca6bf04a3..e476e43842 100644 --- a/R/expect_identical_linter.R +++ b/R/expect_identical_linter.R @@ -77,7 +77,7 @@ expect_identical_linter <- function() { /following-sibling::expr[1][expr[1]/SYMBOL_FUNCTION_CALL[text() = 'identical']] /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { expect_equal_calls <- source_expression$xml_find_function_calls("expect_equal") expect_true_calls <- source_expression$xml_find_function_calls("expect_true") bad_expr <- c( diff --git a/R/expect_length_linter.R b/R/expect_length_linter.R index 880a66357d..c5b21a54b3 100644 --- a/R/expect_length_linter.R +++ b/R/expect_length_linter.R @@ -31,7 +31,7 @@ expect_length_linter <- function() { /parent::expr[not(SYMBOL_SUB[text() = 'info' or contains(text(), 'label')])] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/expect_named_linter.R b/R/expect_named_linter.R index 26d83ceb26..4339bd6d4c 100644 --- a/R/expect_named_linter.R +++ b/R/expect_named_linter.R @@ -40,7 +40,7 @@ expect_named_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) bad_expr <- xml_find_all(xml_calls, xpath) matched_function <- xp_call_name(bad_expr) diff --git a/R/expect_null_linter.R b/R/expect_null_linter.R index 10b15ff38b..e5e8d6597e 100644 --- a/R/expect_null_linter.R +++ b/R/expect_null_linter.R @@ -50,7 +50,7 @@ expect_null_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { expect_equal_identical_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) expect_true_calls <- source_expression$xml_find_function_calls("expect_true") diff --git a/R/expect_s3_class_linter.R b/R/expect_s3_class_linter.R index 7389b2abc2..9866974430 100644 --- a/R/expect_s3_class_linter.R +++ b/R/expect_s3_class_linter.R @@ -66,7 +66,7 @@ expect_s3_class_linter <- function() { /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { expect_equal_identical_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) expect_true_calls <- source_expression$xml_find_function_calls("expect_true") diff --git a/R/expect_s4_class_linter.R b/R/expect_s4_class_linter.R index 61e839a97b..6e8e76653f 100644 --- a/R/expect_s4_class_linter.R +++ b/R/expect_s4_class_linter.R @@ -31,7 +31,7 @@ expect_s4_class_linter <- function() { /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { # TODO(#2423): also catch expect_{equal,identical}(methods::is(x), k). # this seems empirically rare, but didn't check many S4-heavy packages. diff --git a/R/expect_true_false_linter.R b/R/expect_true_false_linter.R index c20eb393eb..dad7637c8c 100644 --- a/R/expect_true_false_linter.R +++ b/R/expect_true_false_linter.R @@ -38,7 +38,7 @@ expect_true_false_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/expect_type_linter.R b/R/expect_type_linter.R index 6d669ed0bd..a9687756ae 100644 --- a/R/expect_type_linter.R +++ b/R/expect_type_linter.R @@ -56,7 +56,7 @@ expect_type_linter <- function() { /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { expect_equal_identical_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) expect_true_calls <- source_expression$xml_find_function_calls("expect_true") bad_expr <- combine_nodesets( diff --git a/R/fixed_regex_linter.R b/R/fixed_regex_linter.R index d3a02fc503..0569232ac0 100644 --- a/R/fixed_regex_linter.R +++ b/R/fixed_regex_linter.R @@ -138,7 +138,7 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { pos_1_calls <- source_expression$xml_find_function_calls(pos_1_regex_funs) pos_2_calls <- source_expression$xml_find_function_calls(pos_2_regex_funs) patterns <- combine_nodesets( diff --git a/R/function_argument_linter.R b/R/function_argument_linter.R index 921e002b22..ac00a99692 100644 --- a/R/function_argument_linter.R +++ b/R/function_argument_linter.R @@ -59,7 +59,7 @@ function_argument_linter <- function() { text() = following-sibling::expr[last()]//expr[expr/SYMBOL_FUNCTION_CALL[text() = 'missing']]/expr[2]/SYMBOL/text() " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/function_left_parentheses_linter.R b/R/function_left_parentheses_linter.R index 07e4ee4382..0a039840a1 100644 --- a/R/function_left_parentheses_linter.R +++ b/R/function_left_parentheses_linter.R @@ -57,7 +57,7 @@ function_left_parentheses_linter <- function() { # nolint: object_length. and @col2 != parent::expr/following-sibling::OP-LEFT-PAREN/@col1 - 1 ]" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_line_fun_exprs <- xml_find_all(xml, bad_line_fun_xpath) diff --git a/R/if_not_else_linter.R b/R/if_not_else_linter.R index 758ba2102f..baef7a10a7 100644 --- a/R/if_not_else_linter.R +++ b/R/if_not_else_linter.R @@ -82,7 +82,7 @@ if_not_else_linter <- function(exceptions = c("is.null", "is.na", "missing")) { ]] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs) diff --git a/R/if_switch_linter.R b/R/if_switch_linter.R index 97b985dac9..da48ccb1fe 100644 --- a/R/if_switch_linter.R +++ b/R/if_switch_linter.R @@ -61,7 +61,7 @@ if_switch_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/ifelse_censor_linter.R b/R/ifelse_censor_linter.R index c43d390e20..9b5b916209 100644 --- a/R/ifelse_censor_linter.R +++ b/R/ifelse_censor_linter.R @@ -45,7 +45,7 @@ ifelse_censor_linter <- function() { /parent::expr ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs) bad_expr <- xml_find_all(ifelse_calls, xpath) diff --git a/R/infix_spaces_linter.R b/R/infix_spaces_linter.R index c7fa7bb1be..5f125bd312 100644 --- a/R/infix_spaces_linter.R +++ b/R/infix_spaces_linter.R @@ -105,7 +105,7 @@ infix_spaces_linter <- function(exclude_operators = NULL, allow_multiple_spaces ) ]") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/inner_combine_linter.R b/R/inner_combine_linter.R index abba413daa..790835cf0e 100644 --- a/R/inner_combine_linter.R +++ b/R/inner_combine_linter.R @@ -82,7 +82,7 @@ inner_combine_linter <- function() { /parent::expr ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("c") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/is_numeric_linter.R b/R/is_numeric_linter.R index 7acc08a3eb..2f0a60d08f 100644 --- a/R/is_numeric_linter.R +++ b/R/is_numeric_linter.R @@ -69,7 +69,7 @@ is_numeric_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content or_expr <- xml_find_all(xml, or_xpath) diff --git a/R/keyword_quote_linter.R b/R/keyword_quote_linter.R index f5f52542c6..54800252d8 100644 --- a/R/keyword_quote_linter.R +++ b/R/keyword_quote_linter.R @@ -93,7 +93,7 @@ keyword_quote_linter <- function() { no_quote_msg <- "Use backticks to create non-syntactic names, not quotes." clarification <- "i.e., if the name is not a valid R symbol (see ?make.names)." - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content xml_calls <- source_expression$xml_find_function_calls(NULL) diff --git a/R/length_test_linter.R b/R/length_test_linter.R index ca163ea9a7..620d8c1d0a 100644 --- a/R/length_test_linter.R +++ b/R/length_test_linter.R @@ -26,7 +26,7 @@ length_test_linter <- function() { /parent::expr ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("length") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/lint.R b/R/lint.R index bf19b195f7..e35895f07b 100644 --- a/R/lint.R +++ b/R/lint.R @@ -75,92 +75,30 @@ lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = supports_exprlist <- vapply(linters[expression_linter_names], linter_supports_exprlist, logical(1L)) lints <- list() - if (!is_tainted(source_expressions$lines)) { + if (!is_tainted(source_expressions$lines) && length(source_expressions$expressions) > 0L) { exprs_expression <- head(source_expressions$expressions, -1L) expr_file <- source_expressions$expressions[[length(source_expressions$expressions)]] - # Compute execution plan - file_linter_cached <- vapply(file_linter_names, has_lint, - expr = expr_file, cache = lint_cache, - FUN.VALUE = logical(1L)) - - # For expression level linters, each column is a linter, each row an expr - expr_linter_cached <- vapply(expression_linter_names, function(linter_name) { - vapply(exprs_expression, has_lint, linter = linter_name, cache = lint_cache, FUN.VALUE = logical(1L)) - }, FUN.VALUE = logical(length(exprs_expression))) - # Ensure 2D array even for just a single expr or linter - dim(expr_linter_cached) <- c(length(exprs_expression), length(expression_linter_names)) - colnames(expr_linter_cached) <- expression_linter_names - - # Retrieve cached lints where available - if (any(file_linter_cached)) { - lints[[length(lints) + 1L]] <- lapply(file_linter_names[file_linter_cached], function(linter_name) { - retrieve_lint(cache = lint_cache, expr = expr_file, linter = linter_name, lines = source_expressions$lines) - }) - } - - if (any(expr_linter_cached)) { - lints[[length(lints) + 1L]] <- lapply( - # only retrieve lints of linters with at least one cache hit - expression_linter_names[colSums(expr_linter_cached) > 0L], - function(linter_name) { - lapply(exprs_expression[expr_linter_cached[, linter_name]], function(expr) { - retrieve_lint(cache = lint_cache, expr = expr, linter = linter_name, lines = source_expressions$lines) - }) - } - ) - } - - # Compute file-level lints where cache missed - if (!all(file_linter_cached)) { - lints[[length(lints) + 1L]] <- lapply(file_linter_names[!file_linter_cached], function(linter_name) { - withCallingHandlers( - get_lints(expr_file, linter_name, linters[[linter_name]], lint_cache, source_expressions$lines), - error = function(cond) { - stop("Linter '", linter_name, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) - } - ) - }) - } - - if (!all(expr_linter_cached)) { - # Compute individual expr-lints where exprlist batching is not supported - needs_running <- colSums(expr_linter_cached) < length(exprs_expression) - lints[[length(lints) + 1L]] <- lapply( - expression_linter_names[needs_running & !supports_exprlist], - function(linter_name) { - lapply(exprs_expression[!expr_linter_cached[, linter_name]], function(expr) { - withCallingHandlers( - get_lints(expr, linter_name, linters[[linter_name]], lint_cache, source_expressions$lines), - error = function(cond) { - stop("Linter '", linter_name, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) - } - ) - }) - } - ) - - lints[[length(lints) + 1L]] <- lapply( - expression_linter_names[needs_running & supports_exprlist], - function(linter_name) { - linter_fun <- linters[[linter_name]] - exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] - - # run on exprlist - exprlist_to_lint <- collapse_exprs(exprs_to_lint) - expr_lints <- flatten_lints(linter_fun(exprlist_to_lint)) - - for (i in seq_along(expr_lints)) { - expr_lints[[i]]$linter <- linter - } - - # write results to expr-level cache - + lints <- handle_file_level_lints( + lints = lints, + file_linter_names = file_linter_names, + expr_file = expr_file, + lint_cache = lint_cache, + linters = linters, + lines = source_expressions$lines, + filename = filename + ) - expr_lints - } - ) - } + lints <- handle_expr_level_lints( + lints = lints, + expression_linter_names = expression_linter_names, + supports_exprlist = supports_exprlist, + exprs_expression = exprs_expression, + lint_cache = lint_cache, + linters = linters, + lines = source_expressions$lines, + filename = filename + ) } lints <- maybe_append_error_lint(lints, source_expressions$error, lint_cache, filename) @@ -349,34 +287,86 @@ lint_package <- function(path = ".", ..., lints } -#' Run a linter on a source expression, optionally using a cache +#' @name get_lints +#' @title Run a linter on a source expression, optionally using a cache #' #' @param expr A source expression. -#' @param linter Name of the linter. +#' @param exprs_to_lint A list of source expressions. +#' @param linter_name Name of the linter. #' @param linter_fun Closure of the linter. #' @param lint_cache Cache environment, or `NULL` if caching is disabled. #' -#' @return A list of lints generated by the linter on `expr`. +#' @return A list of lints generated by the linter on `expr` or all expressions in `exprs_to_lint`. #' #' @noRd -get_lints <- function(expr, linter, linter_fun, lint_cache, lines) { - expr_lints <- NULL - if (has_lint(lint_cache, expr, linter)) { - # retrieve_lint() might return NULL if missing line number is encountered. - # It could be caused by nolint comments. - expr_lints <- retrieve_lint(lint_cache, expr, linter, lines) - } +get_lints_single <- function(expr, linter_name, linter_fun, lint_cache, filename) { + withCallingHandlers( + { + expr_lints <- flatten_lints(linter_fun(expr)) - if (is.null(expr_lints)) { - expr_lints <- flatten_lints(linter_fun(expr)) + for (i in seq_along(expr_lints)) { + expr_lints[[i]]$linter <- linter_name + } + + cache_lint(lint_cache, expr, linter_name, expr_lints) - for (i in seq_along(expr_lints)) { - expr_lints[[i]]$linter <- linter + expr_lints + }, + error = function(cond) { + stop("Linter '", linter_name, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) } + ) +} - cache_lint(lint_cache, expr, linter, expr_lints) - } - expr_lints +#' @rdname get_lints +#' @noRd +get_lints_batched <- function(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) { + withCallingHandlers( + { + # run on exprlist + exprlist_to_lint <- collapse_exprs(exprs_to_lint) + expr_lints <- flatten_lints(linter_fun(exprlist_to_lint)) + + lines_to_cache <- vector(mode = "list", length(exprs_to_lint)) + for (i in seq_along(expr_lints)) { + expr_lints[[i]]$linter <- linter_name + + # Store in cache index if possible (i.e. line number is unique for expr) + curr_expr_index <- exprlist_to_lint$expr_index[as.character(expr_lints[[i]]$line)] + if (!is.na(curr_expr_index)) { + if (is.null(lines_to_cache[[curr_expr_index]])) { + lines_to_cache[[curr_expr_index]] <- list(expr_lints[[i]]) + } else { + lines_to_cache[[curr_expr_index]][[length(lines_to_cache[[curr_expr_index]]) + 1L]] <- expr_lints[[i]] + } + } + } + + # write results to expr-level cache + for (i in seq_along(lines_to_cache)) { + if (!is.null(lines_to_cache[[i]])) { + cache_lint(lint_cache, exprs_to_lint[[i]], linter_name, lines_to_cache[[i]]) + } + } + + expr_lints + }, + error = function(cond) { + stop("Linter '", linter_name, "' failed in ", filename, ": ", conditionMessage(cond), call. = FALSE) + } + ) +} + +#' @rdname get_lints +#' @noRd +get_lints_sequential <- function(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) { + lapply( + exprs_to_lint, get_lints_single, + linter_name = linter_name, + linter_fun = linter_fun, + lint_cache = lint_cache, + filename = filename + ) } define_linters <- function(linters = NULL) { @@ -797,13 +787,22 @@ collapse_exprs <- function(expr_list) { lines <- character() parsed_content <- NULL content <- "" + expr_index <- integer() + i <- 0L for (expr in expr_list) { + i <- i + 1L xml2::xml_add_child(xml_pc, expr$xml_parsed_content) function_call_cache <- c(function_call_cache, expr$xml_find_function_calls(NULL, keep_names = TRUE)) lines <- c(lines, expr$lines) parsed_content <- if (is.null(parsed_content)) expr$parsed_content else rbind(parsed_content, expr$parsed_content) content <- paste(content, expr$content, sep = "\n") + if (expr$line %in% names(expr_index)) { + # line is not unique to this expr => can't find the expr to cache for from exprlist lints landing on this line + expr_index[as.character(expr$line)] <- NA_integer_ + } else { + expr_index[as.character(expr$line)] <- i + } } xml_find_function_calls <- build_xml_find_function_calls(xml_pc, cache = function_call_cache) @@ -813,6 +812,66 @@ collapse_exprs <- function(expr_list) { parsed_content = parsed_content, xml_parsed_content = xml_pc, xml_find_function_calls = xml_find_function_calls, - content = content + content = content, + expr_index = expr_index + ) +} + +handle_file_level_lints <- function(lints, file_linter_names, expr_file, lint_cache, linters, lines, filename) { + # Compute execution plan + file_linter_cached <- vapply( + file_linter_names, has_lint, + expr = expr_file, + cache = lint_cache, + FUN.VALUE = logical(1L) ) + # Retrieve cached lints where available + for (linter_name in file_linter_names[file_linter_cached]) { + lints[[length(lints) + 1L]] <- retrieve_lint( + cache = lint_cache, + expr = expr_file, + linter = linter_name, + lines = lines + ) + } + # Compute file-level lints where cache missed + for (linter_name in file_linter_names[!file_linter_cached]) { + linter_fun <- linters[[linter_name]] + lints[[length(lints) + 1L]] <- get_lints_single(expr_file, linter_name, linter_fun, lint_cache, filename) + } + + lints +} + +handle_expr_level_lints <- function(lints, expression_linter_names, supports_exprlist, exprs_expression, lint_cache, + linters, lines, filename) { + # For expression level linters, each column is a linter, each row an expr + expr_linter_cached <- vapply(expression_linter_names, function(linter_name) { + vapply(exprs_expression, has_lint, linter = linter_name, cache = lint_cache, FUN.VALUE = logical(1L)) + }, FUN.VALUE = logical(length(exprs_expression))) + # Ensure 2D array even for just a single expr or linter + dim(expr_linter_cached) <- c(length(exprs_expression), length(expression_linter_names)) + colnames(expr_linter_cached) <- expression_linter_names + + # Retrieve cached lints where available + for (linter_name in expression_linter_names[colSums(expr_linter_cached) > 0L]) { + lints[[length(lints) + 1L]] <- lapply(exprs_expression[expr_linter_cached[, linter_name]], function(expr) { + retrieve_lint(cache = lint_cache, expr = expr, linter = linter_name, lines = source_expressions$lines) + }) + } + + # Compute individual expr-lints where exprlist batching is not supported + needs_running <- colSums(expr_linter_cached) < length(exprs_expression) + for (linter_name in expression_linter_names[needs_running & !supports_exprlist]) { + linter_fun <- linters[[linter_name]] + exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] + lints[[length(lints) + 1L]] <- get_lints_sequential(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) + } + + # Compute exprlist expr-lints where exprlist batching is supported + for (linter_name in expression_linter_names[needs_running & supports_exprlist]) { + linter_fun <- linters[[linter_name]] + exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] + lints[[length(lints) + 1L]] <- get_lints_batched(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) + } } \ No newline at end of file diff --git a/R/lintr-deprecated.R b/R/lintr-deprecated.R index 549109f2cb..8969caa81a 100644 --- a/R/lintr-deprecated.R +++ b/R/lintr-deprecated.R @@ -147,7 +147,7 @@ extraction_operator_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_exprs <- xml_find_all(xml, xpath) diff --git a/R/list_comparison_linter.R b/R/list_comparison_linter.R index 8303ff80bf..5bea81249c 100644 --- a/R/list_comparison_linter.R +++ b/R/list_comparison_linter.R @@ -38,7 +38,7 @@ list_comparison_linter <- function() { /parent::expr[{ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) }] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(names(list_mapper_alternatives)) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/literal_coercion_linter.R b/R/literal_coercion_linter.R index a64e6b4260..2341f5c0fd 100644 --- a/R/literal_coercion_linter.R +++ b/R/literal_coercion_linter.R @@ -72,7 +72,7 @@ literal_coercion_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(coercers) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/matrix_apply_linter.R b/R/matrix_apply_linter.R index fc12ab3684..c394031bdf 100644 --- a/R/matrix_apply_linter.R +++ b/R/matrix_apply_linter.R @@ -74,7 +74,7 @@ matrix_apply_linter <- function() { margin_xpath <- "expr[position() = 3]" fun_xpath <- "expr[position() = 4]" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("apply") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/nested_ifelse_linter.R b/R/nested_ifelse_linter.R index 6441896c57..f5b1d4bf59 100644 --- a/R/nested_ifelse_linter.R +++ b/R/nested_ifelse_linter.R @@ -85,7 +85,7 @@ nested_ifelse_linter <- function() { /following-sibling::expr[expr[1][SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ]]] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(ifelse_funs) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/nested_pipe_linter.R b/R/nested_pipe_linter.R index fd595b2339..63afb4595e 100644 --- a/R/nested_pipe_linter.R +++ b/R/nested_pipe_linter.R @@ -67,7 +67,7 @@ nested_pipe_linter <- function( ]] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/nzchar_linter.R b/R/nzchar_linter.R index e9f0dadb57..353c69377f 100644 --- a/R/nzchar_linter.R +++ b/R/nzchar_linter.R @@ -126,7 +126,7 @@ nzchar_linter <- function() { op } - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content comparison_expr <- xml_find_all(xml, comparison_xpath) diff --git a/R/object_overwrite_linter.R b/R/object_overwrite_linter.R index 6c2eaa27d1..3a909ca54c 100644 --- a/R/object_overwrite_linter.R +++ b/R/object_overwrite_linter.R @@ -93,7 +93,7 @@ object_overwrite_linter <- function( ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content assigned_exprs <- xml_find_all(xml, xpath_assignments) diff --git a/R/one_call_pipe_linter.R b/R/one_call_pipe_linter.R index b11e3a7b72..9e324ba9b5 100644 --- a/R/one_call_pipe_linter.R +++ b/R/one_call_pipe_linter.R @@ -65,7 +65,7 @@ one_call_pipe_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/outer_negation_linter.R b/R/outer_negation_linter.R index f9f5a67157..2620200720 100644 --- a/R/outer_negation_linter.R +++ b/R/outer_negation_linter.R @@ -49,7 +49,7 @@ outer_negation_linter <- function() { ] " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls(c("any", "all")) bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/paste_linter.R b/R/paste_linter.R index cd054a0683..ca36bd8570 100644 --- a/R/paste_linter.R +++ b/R/paste_linter.R @@ -157,7 +157,7 @@ paste_linter <- function(allow_empty_sep = FALSE, empty_paste_note <- 'Note that paste() converts empty inputs to "", whereas file.path() leaves it empty.' - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { paste_calls <- source_expression$xml_find_function_calls("paste") paste0_calls <- source_expression$xml_find_function_calls("paste0") both_calls <- combine_nodesets(paste_calls, paste0_calls) diff --git a/R/path_utils.R b/R/path_utils.R index d9c47a99cc..8ea69dceb7 100644 --- a/R/path_utils.R +++ b/R/path_utils.R @@ -136,7 +136,7 @@ split_path <- function(dirs, prefix) { #' @include utils.R path_linter_factory <- function(path_function, message, linter, name = linter_auto_name()) { force(name) - Linter(name = name, linter_level = "expression", function(source_expression) { + Linter(name = name, linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { lapply( ids_with_token(source_expression, "STR_CONST"), function(id) { diff --git a/R/pipe_call_linter.R b/R/pipe_call_linter.R index e0b55279ea..64d55e6f7e 100644 --- a/R/pipe_call_linter.R +++ b/R/pipe_call_linter.R @@ -26,7 +26,7 @@ pipe_call_linter <- function() { pipes <- setdiff(magrittr_pipes, "%$%") xpath <- glue("//SPECIAL[{ xp_text_in_table(pipes) }]/following-sibling::expr[*[1][self::SYMBOL]]") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/quotes_linter.R b/R/quotes_linter.R index 10099463ea..d2ef00edb9 100644 --- a/R/quotes_linter.R +++ b/R/quotes_linter.R @@ -60,7 +60,7 @@ quotes_linter <- function(delimiter = c('"', "'")) { lint_message <- "Only use single-quotes." } - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content string_exprs <- xml_find_all(xml, "//STR_CONST") diff --git a/R/redundant_equals_linter.R b/R/redundant_equals_linter.R index 48d524c5b9..2ba397eaa1 100644 --- a/R/redundant_equals_linter.R +++ b/R/redundant_equals_linter.R @@ -43,7 +43,7 @@ redundant_equals_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/redundant_ifelse_linter.R b/R/redundant_ifelse_linter.R index 4c01a3d32e..385adf70da 100644 --- a/R/redundant_ifelse_linter.R +++ b/R/redundant_ifelse_linter.R @@ -68,7 +68,7 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_targets <- source_expression$xml_find_function_calls(ifelse_funs) lints <- list() diff --git a/R/regex_subset_linter.R b/R/regex_subset_linter.R index 33a9fd8d69..9120d1d06a 100644 --- a/R/regex_subset_linter.R +++ b/R/regex_subset_linter.R @@ -66,7 +66,7 @@ regex_subset_linter <- function() { grep_xpath <- glue(xpath_fmt, arg_pos = 3L) stringr_xpath <- glue(xpath_fmt, arg_pos = 2L) - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { grep_calls <- source_expression$xml_find_function_calls(c("grepl", "grep")) grep_expr <- xml_find_all(grep_calls, grep_xpath) diff --git a/R/repeat_linter.R b/R/repeat_linter.R index 877ff0da7a..325fc6fe9f 100644 --- a/R/repeat_linter.R +++ b/R/repeat_linter.R @@ -22,7 +22,7 @@ repeat_linter <- function() { xpath <- "//WHILE[following-sibling::expr[1]/NUM_CONST[text() = 'TRUE']]" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content lints <- xml_find_all(xml, xpath) diff --git a/R/return_linter.R b/R/return_linter.R index 4094ca7551..da827ed807 100644 --- a/R/return_linter.R +++ b/R/return_linter.R @@ -128,7 +128,7 @@ return_linter <- function( params$allow_implicit_else <- allow_implicit_else - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content body_expr <- xml_find_all(xml, body_xpath) diff --git a/R/sample_int_linter.R b/R/sample_int_linter.R index dfdee8d0ee..fe8ec4609e 100644 --- a/R/sample_int_linter.R +++ b/R/sample_int_linter.R @@ -64,7 +64,7 @@ sample_int_linter <- function() { /parent::expr ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("sample") bad_expr <- xml_find_all(xml_calls, xpath) diff --git a/R/scalar_in_linter.R b/R/scalar_in_linter.R index 77ca702854..92882f78e8 100644 --- a/R/scalar_in_linter.R +++ b/R/scalar_in_linter.R @@ -37,7 +37,7 @@ scalar_in_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/seq_linter.R b/R/seq_linter.R index decc02c667..0cef1897fc 100644 --- a/R/seq_linter.R +++ b/R/seq_linter.R @@ -83,7 +83,7 @@ seq_linter <- function() { fun } - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content seq_calls <- source_expression$xml_find_function_calls("seq") diff --git a/R/sort_linter.R b/R/sort_linter.R index 0604b7d232..24a5bf75bd 100644 --- a/R/sort_linter.R +++ b/R/sort_linter.R @@ -97,7 +97,7 @@ sort_linter <- function() { arg_values_xpath <- glue("{arguments_xpath}/following-sibling::expr[1]") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content order_expr <- xml_find_all(xml, order_xpath) diff --git a/R/string_boundary_linter.R b/R/string_boundary_linter.R index fe3727b9e1..8f59556355 100644 --- a/R/string_boundary_linter.R +++ b/R/string_boundary_linter.R @@ -139,7 +139,7 @@ string_boundary_linter <- function(allow_grepl = FALSE) { substr_arg2_xpath <- "string(./expr[expr[1][SYMBOL_FUNCTION_CALL]]/expr[3])" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content lints <- list() diff --git a/R/system_file_linter.R b/R/system_file_linter.R index 24fba540ed..ca947e1d81 100644 --- a/R/system_file_linter.R +++ b/R/system_file_linter.R @@ -35,7 +35,7 @@ system_file_linter <- function() { /parent::expr " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { file_path_calls <- source_expression$xml_find_function_calls("file.path") system_file_calls <- source_expression$xml_find_function_calls("system.file") diff --git a/R/todo_comment_linter.R b/R/todo_comment_linter.R index 8b7169bae2..8265fe797a 100644 --- a/R/todo_comment_linter.R +++ b/R/todo_comment_linter.R @@ -43,7 +43,7 @@ todo_comment_linter <- function(todo = c("todo", "fixme")) { todo_comment_regex <- rex(one_or_more("#"), any_spaces, or(todo)) - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content comment_expr <- xml_find_all(xml, "//COMMENT") diff --git a/R/undesirable_function_linter.R b/R/undesirable_function_linter.R index 762ecda5df..9706e77497 100644 --- a/R/undesirable_function_linter.R +++ b/R/undesirable_function_linter.R @@ -79,7 +79,7 @@ undesirable_function_linter <- function(fun = default_undesirable_functions, } xpath <- glue("self::SYMBOL_FUNCTION_CALL[{xp_condition}]") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content xml_calls <- source_expression$xml_find_function_calls(names(fun)) diff --git a/R/undesirable_operator_linter.R b/R/undesirable_operator_linter.R index 734e6c4856..6c5d5b10bf 100644 --- a/R/undesirable_operator_linter.R +++ b/R/undesirable_operator_linter.R @@ -66,7 +66,7 @@ undesirable_operator_linter <- function(op = default_undesirable_operators) { xpath <- paste(paste0("//", operator_nodes), collapse = " | ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_op <- xml_find_all(xml, xpath) diff --git a/R/unnecessary_concatenation_linter.R b/R/unnecessary_concatenation_linter.R index ed263bfb1e..b3f64775bf 100644 --- a/R/unnecessary_concatenation_linter.R +++ b/R/unnecessary_concatenation_linter.R @@ -95,7 +95,7 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { # ") num_args_xpath <- "count(./expr) - 1" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml_calls <- source_expression$xml_find_function_calls("c") c_calls <- xml_find_all(xml_calls, call_xpath) diff --git a/R/unnecessary_lambda_linter.R b/R/unnecessary_lambda_linter.R index 0ca14d78a9..397460d1d2 100644 --- a/R/unnecessary_lambda_linter.R +++ b/R/unnecessary_lambda_linter.R @@ -156,7 +156,7 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # path to the symbol of the simpler function that avoids a lambda symbol_xpath <- "expr[last()]//expr[SYMBOL_FUNCTION_CALL[text() != 'return']]" - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { default_calls <- source_expression$xml_find_function_calls(apply_funs) default_fun_expr <- xml_find_all(default_calls, default_fun_xpath) diff --git a/R/unnecessary_nesting_linter.R b/R/unnecessary_nesting_linter.R index fdd2a4798e..f4c006d134 100644 --- a/R/unnecessary_nesting_linter.R +++ b/R/unnecessary_nesting_linter.R @@ -141,7 +141,7 @@ unnecessary_nesting_linter <- function(allow_assignment = TRUE) { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content if_else_exit_expr <- xml_find_all(xml, if_else_exit_xpath) diff --git a/R/unnecessary_placeholder_linter.R b/R/unnecessary_placeholder_linter.R index 9e546326d9..894288e6b6 100644 --- a/R/unnecessary_placeholder_linter.R +++ b/R/unnecessary_placeholder_linter.R @@ -49,7 +49,7 @@ unnecessary_placeholder_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/unreachable_code_linter.R b/R/unreachable_code_linter.R index 124b5a12f0..f669c8cec0 100644 --- a/R/unreachable_code_linter.R +++ b/R/unreachable_code_linter.R @@ -134,7 +134,7 @@ unreachable_code_linter <- function(allow_comment_regex = getOption("covr.exclud expr[!is_valid_comment] } - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content # run here because 'settings$exclude_end' may not be set correctly at "compile time". diff --git a/R/utils.R b/R/utils.R index 159d58fdf0..88c93db975 100644 --- a/R/utils.R +++ b/R/utils.R @@ -162,10 +162,14 @@ reset_lang <- function(old_lang) { #' `"expression"` means an individual expression in `xml_parsed_content`, while `"file"` means all expressions #' in the current file are available in `full_xml_parsed_content`. #' `NA` means the linter will be run with both, expression-level and file-level source expressions. +#' @param supports_exprlist Relevant for expression-level linters. If TRUE, signals that the linter can accept +#' source expressions that contain multiple individual expressions in `xml_parsed_content`. #' #' @return The same function with its class set to 'linter'. #' @export -Linter <- function(fun, name = linter_auto_name(), linter_level = c(NA_character_, "file", "expression")) { # nolint: object_name, line_length. +# nolint next: object_name. +Linter <- function(fun, name = linter_auto_name(), linter_level = c(NA_character_, "file", "expression"), + supports_exprlist = FALSE) { if (!is.function(fun) || length(formals(args(fun))) != 1L) { stop("`fun` must be a function taking exactly one argument.", call. = FALSE) } diff --git a/R/vector_logic_linter.R b/R/vector_logic_linter.R index 1b18ceda05..2ed35402df 100644 --- a/R/vector_logic_linter.R +++ b/R/vector_logic_linter.R @@ -81,7 +81,7 @@ vector_logic_linter <- function() { ] " - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { xml <- source_expression$xml_parsed_content bad_expr <- xml_find_all(xml, xpath) diff --git a/R/yoda_test_linter.R b/R/yoda_test_linter.R index 1b4b0c6717..8972d5af06 100644 --- a/R/yoda_test_linter.R +++ b/R/yoda_test_linter.R @@ -54,7 +54,7 @@ yoda_test_linter <- function() { second_const_xpath <- glue("expr[position() = 3 and ({const_condition})]") - Linter(linter_level = "expression", function(source_expression) { + Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { bad_expr <- xml_find_all( source_expression$xml_find_function_calls(c("expect_equal", "expect_identical", "expect_setequal")), xpath From d92d504d48fe8e3a106f0f728b894f3c35bab9c4 Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 00:52:51 +0100 Subject: [PATCH 04/11] fix missing return from handle_expr_level_lints(), actually enable batching --- R/cyclocomp_linter.R | 2 +- R/lint.R | 4 +++- R/utils.R | 1 + 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/R/cyclocomp_linter.R b/R/cyclocomp_linter.R index 0c103f188a..c5563646f2 100644 --- a/R/cyclocomp_linter.R +++ b/R/cyclocomp_linter.R @@ -22,7 +22,7 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export cyclocomp_linter <- function(complexity_limit = 15L) { - Linter(linter_level = "expression", supports_exprlist = TRUE, function(source_expression) { + Linter(linter_level = "expression", function(source_expression) { complexity <- try_silently( cyclocomp::cyclocomp(parse(text = source_expression$content)) ) diff --git a/R/lint.R b/R/lint.R index 367afaeb69..4f5ddb5b87 100644 --- a/R/lint.R +++ b/R/lint.R @@ -791,7 +791,7 @@ collapse_exprs <- function(expr_list) { for (expr in expr_list) { i <- i + 1L xml2::xml_add_child(xml_pc, expr$xml_parsed_content) - function_call_cache <- c(function_call_cache, expr$xml_find_function_calls(NULL, keep_names = TRUE)) + function_call_cache <- combine_nodesets(function_call_cache, expr$xml_find_function_calls(NULL, keep_names = TRUE)) lines <- c(lines, expr$lines) parsed_content <- if (is.null(parsed_content)) expr$parsed_content else rbind(parsed_content, expr$parsed_content) content <- paste(content, expr$content, sep = "\n") @@ -872,4 +872,6 @@ handle_expr_level_lints <- function(lints, expression_linter_names, supports_exp exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] lints[[length(lints) + 1L]] <- get_lints_batched(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) } + + lints } \ No newline at end of file diff --git a/R/utils.R b/R/utils.R index 88c93db975..51e5e4b002 100644 --- a/R/utils.R +++ b/R/utils.R @@ -178,6 +178,7 @@ Linter <- function(fun, name = linter_auto_name(), linter_level = c(NA_character class(fun) <- c("linter", "function") attr(fun, "name") <- name attr(fun, "linter_level") <- linter_level + attr(fun, "linter_exprlist") <- isTRUE(supports_exprlist) fun } From 43387bb7a8cb1cc122eadc1b626ae66c578dccfc Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:02:06 +0100 Subject: [PATCH 05/11] speed up collapse_exprs() --- R/lint.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/lint.R b/R/lint.R index 4f5ddb5b87..33f2ef8170 100644 --- a/R/lint.R +++ b/R/lint.R @@ -783,17 +783,20 @@ collapse_exprs <- function(expr_list) { function_call_cache <- list() filename <- expr_list[[1L]]$filename lines <- character() - parsed_content <- NULL + parsed_content <- do.call(rbind, lapply(expr_list, function(expr) expr$parsed_content)) content <- "" expr_index <- integer() i <- 0L + for (expr in rev(expr_list)) { + # prepending is _much_ faster than appending, because it avoids a call to xml_children(). + xml2::xml_add_child(xml_pc, expr$xml_parsed_content, .where = 0L) + } + for (expr in expr_list) { i <- i + 1L - xml2::xml_add_child(xml_pc, expr$xml_parsed_content) function_call_cache <- combine_nodesets(function_call_cache, expr$xml_find_function_calls(NULL, keep_names = TRUE)) lines <- c(lines, expr$lines) - parsed_content <- if (is.null(parsed_content)) expr$parsed_content else rbind(parsed_content, expr$parsed_content) content <- paste(content, expr$content, sep = "\n") if (expr$line %in% names(expr_index)) { # line is not unique to this expr => can't find the expr to cache for from exprlist lints landing on this line From 72142bd08c650161d1edc13334a82b746099432a Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:04:07 +0100 Subject: [PATCH 06/11] delint --- R/lint.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/lint.R b/R/lint.R index 33f2ef8170..1fdbe2b391 100644 --- a/R/lint.R +++ b/R/lint.R @@ -857,7 +857,7 @@ handle_expr_level_lints <- function(lints, expression_linter_names, supports_exp # Retrieve cached lints where available for (linter_name in expression_linter_names[colSums(expr_linter_cached) > 0L]) { lints[[length(lints) + 1L]] <- lapply(exprs_expression[expr_linter_cached[, linter_name]], function(expr) { - retrieve_lint(cache = lint_cache, expr = expr, linter = linter_name, lines = source_expressions$lines) + retrieve_lint(cache = lint_cache, expr = expr, linter = linter_name, lines = lines) }) } @@ -877,4 +877,4 @@ handle_expr_level_lints <- function(lints, expression_linter_names, supports_exp } lints -} \ No newline at end of file +} From 1146fe7f3435ea1960b18aa3a58890ee697acd20 Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:23:17 +0100 Subject: [PATCH 07/11] optimize collapse_exprs() --- R/lint.R | 84 ++++++++++++++++++++++++++------------ man/Linter.Rd | 6 ++- man/todo_comment_linter.Rd | 15 +++---- 3 files changed, 69 insertions(+), 36 deletions(-) diff --git a/R/lint.R b/R/lint.R index 1fdbe2b391..2db6721915 100644 --- a/R/lint.R +++ b/R/lint.R @@ -92,6 +92,7 @@ lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = expression_linter_names = expression_linter_names, supports_exprlist = supports_exprlist, exprs_expression = exprs_expression, + expr_file = expr_file, lint_cache = lint_cache, linters = linters, lines = source_expressions$lines, @@ -318,11 +319,10 @@ get_lints_single <- function(expr, linter_name, linter_fun, lint_cache, filename #' @rdname get_lints #' @noRd -get_lints_batched <- function(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) { +get_lints_batched <- function(exprs_to_lint, exprlist_to_lint, linter_name, linter_fun, lint_cache, filename) { withCallingHandlers( { # run on exprlist - exprlist_to_lint <- collapse_exprs(exprs_to_lint) expr_lints <- flatten_lints(linter_fun(exprlist_to_lint)) lines_to_cache <- vector(mode = "list", length(exprs_to_lint)) @@ -771,33 +771,44 @@ zap_temp_filename <- function(res, needs_tempfile) { #' #' @param expr_list A list containing expression-level source expressions #' -#' @value An exprlist-level source expression +#' @return An exprlist-level source expression #' #' @keywords internal #' @noRd -collapse_exprs <- function(expr_list) { +collapse_exprs <- function(expr_list, expr_file) { if (length(expr_list) == 0L) { return(list()) } - xml_pc <- xml2::xml_new_root("exprlist") - function_call_cache <- list() - filename <- expr_list[[1L]]$filename - lines <- character() - parsed_content <- do.call(rbind, lapply(expr_list, function(expr) expr$parsed_content)) - content <- "" - expr_index <- integer() - i <- 0L + if (!missing(expr_file)) { + xml_pc <- expr_file$full_xml_parsed_content + parsed_content <- expr_file$full_parsed_content + xml_find_function_calls <- expr_file$xml_find_function_calls + lines <- expr_file$file_lines + } else { + xml_pc <- xml2::xml_new_root("exprlist") + + for (expr in rev(expr_list)) { + # prepending is _much_ faster than appending, because it avoids a call to xml_children(). + xml2::xml_add_child(xml_pc, expr$xml_parsed_content, .where = 0L) + } + + parsed_content <- do.call(rbind, lapply(expr_list, function(expr) expr$parsed_content)) + + function_call_cache <- do.call( + combine_nodesets, + lapply(expr_list, function(expr) expr$xml_find_function_calls(NULL, keep_names = TRUE)) + ) + xml_find_function_calls <- build_xml_find_function_calls(xml_pc, cache = function_call_cache) - for (expr in rev(expr_list)) { - # prepending is _much_ faster than appending, because it avoids a call to xml_children(). - xml2::xml_add_child(xml_pc, expr$xml_parsed_content, .where = 0L) + lines <- do.call(c, lapply(expr_list, function(expr) expr$lines)) } + filename <- expr_list[[1L]]$filename + content <- paste(vapply(expr_list, function(expr) expr$content, character(1L)), collapse = "\n") + expr_index <- integer() + i <- 0L for (expr in expr_list) { i <- i + 1L - function_call_cache <- combine_nodesets(function_call_cache, expr$xml_find_function_calls(NULL, keep_names = TRUE)) - lines <- c(lines, expr$lines) - content <- paste(content, expr$content, sep = "\n") if (expr$line %in% names(expr_index)) { # line is not unique to this expr => can't find the expr to cache for from exprlist lints landing on this line expr_index[as.character(expr$line)] <- NA_integer_ @@ -805,7 +816,6 @@ collapse_exprs <- function(expr_list) { expr_index[as.character(expr$line)] <- i } } - xml_find_function_calls <- build_xml_find_function_calls(xml_pc, cache = function_call_cache) list( filename = filename, @@ -838,14 +848,20 @@ handle_file_level_lints <- function(lints, file_linter_names, expr_file, lint_ca # Compute file-level lints where cache missed for (linter_name in file_linter_names[!file_linter_cached]) { linter_fun <- linters[[linter_name]] - lints[[length(lints) + 1L]] <- get_lints_single(expr_file, linter_name, linter_fun, lint_cache, filename) + lints[[length(lints) + 1L]] <- get_lints_single( + expr = expr_file, + linter_name = linter_name, + linter_fun = linter_fun, + lint_cache = lint_cache, + filename = filename + ) } lints } -handle_expr_level_lints <- function(lints, expression_linter_names, supports_exprlist, exprs_expression, lint_cache, - linters, lines, filename) { +handle_expr_level_lints <- function(lints, expression_linter_names, supports_exprlist, exprs_expression, expr_file, + lint_cache, linters, lines, filename) { # For expression level linters, each column is a linter, each row an expr expr_linter_cached <- vapply(expression_linter_names, function(linter_name) { vapply(exprs_expression, has_lint, linter = linter_name, cache = lint_cache, FUN.VALUE = logical(1L)) @@ -866,14 +882,32 @@ handle_expr_level_lints <- function(lints, expression_linter_names, supports_exp for (linter_name in expression_linter_names[needs_running & !supports_exprlist]) { linter_fun <- linters[[linter_name]] exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] - lints[[length(lints) + 1L]] <- get_lints_sequential(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) + lints[[length(lints) + 1L]] <- get_lints_sequential( + exprs_to_lint = exprs_to_lint, + linter_name = linter_name, + linter_fun = linter_fun, + lint_cache = lint_cache, + filename = filename + ) } # Compute exprlist expr-lints where exprlist batching is supported for (linter_name in expression_linter_names[needs_running & supports_exprlist]) { linter_fun <- linters[[linter_name]] - exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] - lints[[length(lints) + 1L]] <- get_lints_batched(exprs_to_lint, linter_name, linter_fun, lint_cache, filename) + if (!any(expr_linter_cached[, linter_name])) { + exprlist_to_lint <- collapse_exprs(exprs_to_lint, expr_file = expr_file) + } else { + exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] + exprlist_to_lint <- collapse_exprs(exprs_to_lint) + } + lints[[length(lints) + 1L]] <- get_lints_batched( + exprs_to_lint = exprs_to_lint, + exprlist_to_lint = exprlist_to_lint, + linter_name = linter_name, + linter_fun = linter_fun, + lint_cache = lint_cache, + filename = filename + ) } lints diff --git a/man/Linter.Rd b/man/Linter.Rd index ef8c5ccd8c..a93c8680f4 100644 --- a/man/Linter.Rd +++ b/man/Linter.Rd @@ -7,7 +7,8 @@ Linter( fun, name = linter_auto_name(), - linter_level = c(NA_character_, "file", "expression") + linter_level = c(NA_character_, "file", "expression"), + supports_exprlist = FALSE ) } \arguments{ @@ -20,6 +21,9 @@ Lints produced by the linter will be labelled with \code{name} by default.} \code{"expression"} means an individual expression in \code{xml_parsed_content}, while \code{"file"} means all expressions in the current file are available in \code{full_xml_parsed_content}. \code{NA} means the linter will be run with both, expression-level and file-level source expressions.} + +\item{supports_exprlist}{Relevant for expression-level linters. If TRUE, signals that the linter can accept +source expressions that contain multiple individual expressions in \code{xml_parsed_content}.} } \value{ The same function with its class set to 'linter'. diff --git a/man/todo_comment_linter.Rd b/man/todo_comment_linter.Rd index 24b730eabf..29dde11f9b 100644 --- a/man/todo_comment_linter.Rd +++ b/man/todo_comment_linter.Rd @@ -18,22 +18,17 @@ Check that the source contains no TODO comments (case-insensitive). \examples{ # will produce lints lint( - text = "x + y # TODO", - linters = todo_comment_linter() -) - -lint( - text = "pi <- 1.0 # FIXME", - linters = todo_comment_linter() + text = "x + y # TOODOO", + linters = todo_comment_linter(todo = "toodoo") ) lint( - text = "x <- TRUE # hack", - linters = todo_comment_linter(todo = c("todo", "fixme", "hack")) + text = "pi <- 1.0 # FIIXMEE", + linters = todo_comment_linter(todo = "fiixmee") ) lint( - text = "x <- TRUE # TODO(#1234): Fix this hack.", + text = "x <- TRUE # TOODOO(#1234): Fix this hack.", linters = todo_comment_linter() ) From e1fac0fa12e8f224a8b485a19414bf747993f94b Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:24:16 +0100 Subject: [PATCH 08/11] fix tests --- R/lint.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/lint.R b/R/lint.R index 2db6721915..8517983258 100644 --- a/R/lint.R +++ b/R/lint.R @@ -895,6 +895,7 @@ handle_expr_level_lints <- function(lints, expression_linter_names, supports_exp for (linter_name in expression_linter_names[needs_running & supports_exprlist]) { linter_fun <- linters[[linter_name]] if (!any(expr_linter_cached[, linter_name])) { + exprs_to_lint <- exprs_expression exprlist_to_lint <- collapse_exprs(exprs_to_lint, expr_file = expr_file) } else { exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] From 03e4cddc6ded8025685c22fc1f6c42165e2aa2be Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:28:39 +0100 Subject: [PATCH 09/11] delint --- R/lint.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/lint.R b/R/lint.R index 8517983258..00a18d1e45 100644 --- a/R/lint.R +++ b/R/lint.R @@ -894,12 +894,12 @@ handle_expr_level_lints <- function(lints, expression_linter_names, supports_exp # Compute exprlist expr-lints where exprlist batching is supported for (linter_name in expression_linter_names[needs_running & supports_exprlist]) { linter_fun <- linters[[linter_name]] - if (!any(expr_linter_cached[, linter_name])) { - exprs_to_lint <- exprs_expression - exprlist_to_lint <- collapse_exprs(exprs_to_lint, expr_file = expr_file) - } else { + if (any(expr_linter_cached[, linter_name])) { exprs_to_lint <- exprs_expression[!expr_linter_cached[, linter_name]] exprlist_to_lint <- collapse_exprs(exprs_to_lint) + } else { + exprs_to_lint <- exprs_expression + exprlist_to_lint <- collapse_exprs(exprs_to_lint, expr_file = expr_file) } lints[[length(lints) + 1L]] <- get_lints_batched( exprs_to_lint = exprs_to_lint, From f5e633d3bc033306073c96a0a119a365381016dc Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:41:54 +0100 Subject: [PATCH 10/11] add NEWS.md, try disabling batch-cache to check tests --- NEWS.md | 3 ++- R/lint.R | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 830f8be46a..c9533bcd56 100644 --- a/NEWS.md +++ b/NEWS.md @@ -38,6 +38,7 @@ * `unnecessary_lambda_linter` is extended to encourage vectorized comparisons where possible, e.g. `sapply(x, sum) > 0` instead of `sapply(x, function(x) sum(x) > 0)` (part of #884, @MichaelChirico). Toggle this behavior with argument `allow_comparison`. * `backport_linter()` is slightly faster by moving expensive computations outside the linting function (#2339, #2348, @AshesITR and @MichaelChirico). * `Linter()` has a new argument `linter_level` (default `NA`). This is used by `lint()` to more efficiently check for expression levels than the idiom `if (!is_lint_level(...)) { return(list()) }` (#2351, @AshesITR). +* `Linter()` has a new argument `supports_exprlist` (default `FALSE`). This is used by `lint()` to more efficiently run expression-level linters if they support linting multiple expressions in parallel. Most linters are cacheable on the expression level, but support running for many expressions in parallel. Exprlist linting mode aggregates expressions before calling the linter and causes linting to be roughly 2x faster (#2449, @AshesITR). * `string_boundary_linter()` recognizes regular expression calls like `grepl("^abc$", x)` that can be replaced by using `==` instead (#1613, @MichaelChirico). * `unreachable_code_linter()` has an argument `allow_comment_regex` for customizing which "terminal" comments to exclude (#2327, @MichaelChirico). `# nolint end` comments are always excluded, as are {covr} exclusions (e.g. `# nocov end`) by default. * `format()` and `print()` methods for `lint` and `lints` classes get a new option `width` to control the printing width of lint messages (#1884, @MichaelChirico). The default is controlled by a new option `lintr.format_width`; if unset, no wrapping occurs (matching earlier behavior). @@ -45,7 +46,7 @@ * New function node caching for big efficiency gains to most linters (e.g. overall `lint_package()` improvement of 14-27% and core linting improvement up to 30%; #2357, @AshesITR). Most linters are written around function usage, and XPath performance searching for many functions is poor. The new `xml_find_function_calls()` entry in the `get_source_expressions()` output caches all function call nodes instead. See the vignette on creating linters for more details on how to use it. * `todo_comment_linter()` has a new argument `except_regex` for setting _valid_ TODO comments, e.g. for forcing TODO comments to be linked to GitHub issues like `TODO(#154)` (#2047, @MichaelChirico). * `vector_logic_linter()` is extended to recognize incorrect usage of scalar operators `&&` and `||` inside subsetting expressions like `dplyr::filter(x, A && B)` (#2166, @MichaelChirico). -* `any_is_na_linter()` is extended to catch the unusual usage `NA %in% x` (#2113, @MichaelChirico). +* `any_is_na_linter()` is extended to catch the unusual usage `NA %in% x` (#2113, @MichaelChirico). ### New linters diff --git a/R/lint.R b/R/lint.R index 00a18d1e45..bf5df87aed 100644 --- a/R/lint.R +++ b/R/lint.R @@ -343,7 +343,7 @@ get_lints_batched <- function(exprs_to_lint, exprlist_to_lint, linter_name, lint # write results to expr-level cache for (i in seq_along(lines_to_cache)) { if (!is.null(lines_to_cache[[i]])) { - cache_lint(lint_cache, exprs_to_lint[[i]], linter_name, lines_to_cache[[i]]) + #> cache_lint(lint_cache, exprs_to_lint[[i]], linter_name, lines_to_cache[[i]]) } } From 41a2163271efb78331988b5b9e360c5bbc84cd9e Mon Sep 17 00:00:00 2001 From: Alexander Rosenstock Date: Sat, 16 Dec 2023 01:55:54 +0100 Subject: [PATCH 11/11] move supports_exprlist --- R/lint.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/R/lint.R b/R/lint.R index bf5df87aed..5c2799abc4 100644 --- a/R/lint.R +++ b/R/lint.R @@ -70,7 +70,6 @@ lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = file_linter_names <- names(linters)[vapply(linters, is_linter_level, logical(1L), "file")] expression_linter_names <- names(linters)[vapply(linters, is_linter_level, logical(1L), "expression")] - supports_exprlist <- vapply(linters[expression_linter_names], linter_supports_exprlist, logical(1L)) lints <- list() if (!is_tainted(source_expressions$lines) && length(source_expressions$expressions) > 0L) { @@ -90,7 +89,6 @@ lint <- function(filename, linters = NULL, ..., cache = FALSE, parse_settings = lints <- handle_expr_level_lints( lints = lints, expression_linter_names = expression_linter_names, - supports_exprlist = supports_exprlist, exprs_expression = exprs_expression, expr_file = expr_file, lint_cache = lint_cache, @@ -343,7 +341,7 @@ get_lints_batched <- function(exprs_to_lint, exprlist_to_lint, linter_name, lint # write results to expr-level cache for (i in seq_along(lines_to_cache)) { if (!is.null(lines_to_cache[[i]])) { - #> cache_lint(lint_cache, exprs_to_lint[[i]], linter_name, lines_to_cache[[i]]) + cache_lint(lint_cache, exprs_to_lint[[i]], linter_name, lines_to_cache[[i]]) } } @@ -809,12 +807,10 @@ collapse_exprs <- function(expr_list, expr_file) { i <- 0L for (expr in expr_list) { i <- i + 1L - if (expr$line %in% names(expr_index)) { - # line is not unique to this expr => can't find the expr to cache for from exprlist lints landing on this line - expr_index[as.character(expr$line)] <- NA_integer_ - } else { - expr_index[as.character(expr$line)] <- i - } + curr_lines <- names(expr$lines) + # line is not unique to this expr => can't find the expr to cache for from exprlist lints landing on this line + expr_index[intersect(curr_lines, names(expr_index))] <- NA_integer_ + expr_index[setdiff(curr_lines, names(expr_index))] <- i } list( @@ -862,10 +858,14 @@ handle_file_level_lints <- function(lints, file_linter_names, expr_file, lint_ca handle_expr_level_lints <- function(lints, expression_linter_names, supports_exprlist, exprs_expression, expr_file, lint_cache, linters, lines, filename) { + + supports_exprlist <- vapply(linters[expression_linter_names], linter_supports_exprlist, logical(1L)) + # For expression level linters, each column is a linter, each row an expr expr_linter_cached <- vapply(expression_linter_names, function(linter_name) { vapply(exprs_expression, has_lint, linter = linter_name, cache = lint_cache, FUN.VALUE = logical(1L)) }, FUN.VALUE = logical(length(exprs_expression))) + # Ensure 2D array even for just a single expr or linter dim(expr_linter_cached) <- c(length(exprs_expression), length(expression_linter_names)) colnames(expr_linter_cached) <- expression_linter_names