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 e7915d856..224884a7a 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 d850c51cf..422fded83 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 224884a7a..bf19b195f 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 3179847af..cfef05527 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 b6c1300c7..4879a9758 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 04a80bd84..bc43a6055 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 a0ea91e33..4a915449a 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 da42b5119..fafc89cae 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 3c1eaeaeb..83590ed01 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 c0d0c755c..e29cc8c75 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 eebdb90ec..7281409f9 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 2dd24b83d..a9656269b 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 aeaf42878..cfd3946fe 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 f2c3424ab..7f8116d13 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 8b13c8a92..bd777d12a 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 e20e53b4b..baa914240 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 c5563646f..0c103f188 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 2961ac984..0c05f65a6 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 87dc24169..af15a9893 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 4ca6bf04a..e476e4384 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 880a66357..c5b21a54b 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 26d83ceb2..4339bd6d4 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 10b15ff38..e5e8d6597 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 7389b2abc..986697443 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 61e839a97..6e8e76653 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 c20eb393e..dad7637c8 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 6d669ed0b..a9687756a 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 d3a02fc50..0569232ac 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 921e002b2..ac00a9969 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 07e4ee438..0a039840a 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 758ba2102..baef7a10a 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 97b985dac..da48ccb1f 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 c43d390e2..9b5b91620 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 c7fa7bb1b..5f125bd31 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 abba413da..790835cf0 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 7acc08a3e..2f0a60d08 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 f5f52542c..54800252d 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 ca163ea9a..620d8c1d0 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 bf19b195f..e35895f07 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 549109f2c..8969caa81 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 8303ff80b..5bea81249 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 a64e6b426..2341f5c0f 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 fc12ab368..c394031bd 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 6441896c5..f5b1d4bf5 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 fd595b233..63afb4595 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 e9f0dadb5..353c69377 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 6c2eaa27d..3a909ca54 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 b11e3a7b7..9e324ba9b 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 f9f5a6715..262020072 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 cd054a068..ca36bd857 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 d9c47a99c..8ea69dceb 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 e0b55279e..64d55e6f7 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 10099463e..d2ef00edb 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 48d524c5b..2ba397eaa 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 4c01a3d32..385adf70d 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 33a9fd8d6..9120d1d06 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 877ff0da7..325fc6fe9 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 4094ca755..da827ed80 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 dfdee8d0e..fe8ec4609 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 77ca70285..92882f78e 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 decc02c66..0cef1897f 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 0604b7d23..24a5bf75b 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 fe3727b9e..8f5955635 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 24fba540e..ca947e1d8 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 8b7169bae..8265fe797 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 762ecda5d..9706e7749 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 734e6c485..6c5d5b10b 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 ed263bfb1..b3f64775b 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 0ca14d78a..397460d1d 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 fdd2a4798..f4c006d13 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 9e546326d..894288e6b 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 124b5a12f..f669c8cec 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 159d58fdf..88c93db97 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 1b18ceda0..2ed35402d 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 1b4b0c671..8972d5af0 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 0c103f188..c5563646f 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 367afaeb6..4f5ddb5b8 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 88c93db97..51e5e4b00 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 4f5ddb5b8..33f2ef817 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 33f2ef817..1fdbe2b39 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 1fdbe2b39..2db672191 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 ef8c5ccd8..a93c8680f 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 24b730eab..29dde11f9 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 2db672191..851798325 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 851798325..00a18d1e4 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 830f8be46..c9533bcd5 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 00a18d1e4..bf5df87ae 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 bf5df87ae..5c2799abc 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