From 538440d5e4f3f87c4835cd6161db82c32fb48ace Mon Sep 17 00:00:00 2001 From: AshesITR Date: Wed, 13 Dec 2023 16:00:35 +0100 Subject: [PATCH] add `xml_find_function_calls()` helper to source expressions (#2357) * add first implementation of xml_find_function_calls * delint * support getting all function calls and using names. * squash conversions * review comments * clean up * add vignette section and NEWS bullet * smarter conjunct_test_linter migration * smarter consecutive_assertion_linter migration * remove self::SYMBOL_FUNCTION_CALL[text() = ...] xpaths * delint * Update expect_s3_class_linter.R * Reference GH issue # in TODO * review comments * add missing comma in example * Update NEWS.md * supersede #2365 * Update R/xp_utils.R Co-authored-by: Michael Chirico * fix bad commit * Update NEWS.md * Add an upper bound improvement from r-devel --------- Co-authored-by: Michael Chirico Co-authored-by: Michael Chirico --- DESCRIPTION | 1 + NAMESPACE | 1 + NEWS.md | 6 +++ R/any_duplicated_linter.R | 6 +-- R/any_is_na_linter.R | 8 ++-- R/backport_linter.R | 17 ++++--- R/boolean_arithmetic_linter.R | 16 +++---- R/class_equals_linter.R | 8 ++-- R/condition_call_linter.R | 11 ++--- R/condition_message_linter.R | 10 ++-- R/conjunct_test_linter.R | 32 ++++++------- R/consecutive_assertion_linter.R | 20 ++++---- R/consecutive_mutate_linter.R | 12 +++-- R/expect_comparison_linter.R | 8 ++-- R/expect_identical_linter.R | 16 +++---- R/expect_length_linter.R | 7 ++- R/expect_named_linter.R | 8 ++-- R/expect_not_linter.R | 6 +-- R/expect_null_linter.R | 15 +++--- R/expect_s3_class_linter.R | 15 +++--- R/expect_s4_class_linter.R | 11 ++--- R/expect_true_false_linter.R | 8 ++-- R/expect_type_linter.R | 16 +++---- R/fixed_regex_linter.R | 28 ++++++----- R/function_return_linter.R | 8 ++-- R/get_source_expressions.R | 40 +++++++++------- R/if_not_else_linter.R | 6 +-- R/ifelse_censor_linter.R | 8 ++-- R/inner_combine_linter.R | 8 ++-- R/keyword_quote_linter.R | 6 +-- R/length_levels_linter.R | 6 +-- R/length_test_linter.R | 7 ++- R/lengths_linter.R | 16 ++----- R/list_comparison_linter.R | 8 ++-- R/literal_coercion_linter.R | 12 ++--- R/make_linter_from_xpath.R | 35 ++++++++++++++ R/matrix_apply_linter.R | 11 ++--- R/missing_argument_linter.R | 8 ++-- R/missing_package_linter.R | 16 +++---- R/nested_ifelse_linter.R | 8 ++-- R/nrow_subset_linter.R | 6 +-- R/nzchar_linter.R | 6 +-- R/outer_negation_linter.R | 8 ++-- R/paste_linter.R | 38 +++++++-------- R/print_linter.R | 6 +-- R/redundant_ifelse_linter.R | 12 ++--- R/regex_subset_linter.R | 15 +++--- R/rep_len_linter.R | 6 +-- R/routine_registration_linter.R | 21 ++++---- R/sample_int_linter.R | 7 ++- R/seq_linter.R | 11 +++-- R/sort_linter.R | 6 +-- R/source_utils.R | 23 +++++++++ R/sprintf_linter.R | 8 ++-- R/stopifnot_all_linter.R | 6 +-- R/string_boundary_linter.R | 18 +++---- R/strings_as_factors_linter.R | 27 ++++------- R/system_file_linter.R | 21 ++++---- R/undesirable_function_linter.R | 14 +++--- R/unnecessary_concatenation_linter.R | 8 ++-- R/unnecessary_lambda_linter.R | 24 +++++----- R/unused_import_linter.R | 11 +++-- R/which_grepl_linter.R | 6 +-- R/xp_utils.R | 12 +++++ R/yoda_test_linter.R | 14 +++--- man/default_undesirable_functions.Rd | 4 +- man/get_source_expressions.Rd | 36 +++++++------- man/make_linter_from_xpath.Rd | 13 +++++ tests/testthat/test-get_source_expressions.R | 50 +++++++++++++++++++- vignettes/creating_linters.Rmd | 22 ++++++++- 70 files changed, 534 insertions(+), 414 deletions(-) create mode 100644 R/source_utils.R diff --git a/DESCRIPTION b/DESCRIPTION index ffa56a981..8feb6297e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -175,6 +175,7 @@ Collate: 'settings_utils.R' 'shared_constants.R' 'sort_linter.R' + 'source_utils.R' 'spaces_inside_linter.R' 'spaces_left_parentheses_linter.R' 'sprintf_linter.R' diff --git a/NAMESPACE b/NAMESPACE index 3b4b473bf..00d9ad2e0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -95,6 +95,7 @@ export(linters_with_defaults) export(linters_with_tags) export(list_comparison_linter) export(literal_coercion_linter) +export(make_linter_from_function_xpath) export(make_linter_from_xpath) export(matrix_apply_linter) export(missing_argument_linter) diff --git a/NEWS.md b/NEWS.md index 5c8ec3b9e..acbaf6c90 100644 --- a/NEWS.md +++ b/NEWS.md @@ -40,6 +40,12 @@ * `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). +* 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. +* The full linter suite is roughly 14% faster due to caching of the frequently used `//SYMBOL_FUNCTION_CALL` XPath to examine function calls. (@AshesITR, #2357) + + The `source_expression` passed to linters gains a fast way to query function call nodes using `source_expression$xml_find_function_calls()`. Use this to speed up linters using XPaths that start with `//SYMBOL_FUNCTION_CALL`. + + The vignette on creating linters contains additional information on how to use it. + + Instead of `xml_find_all(source_expression$xml_parsed_content, "//SYMBOL_FUNCTION_CALL[text() = 'foo' or text() = 'bar']`, use `source_expression$xml_find_function_calls(c("foo", "bar"))`. + + Instead of `make_linter_from_xpath(xpath = "//SYMBOL_FUNCTION_CALL[text() = 'foo' or text() = 'bar']/cond")`, use the new `make_linter_from_function_xpath(function_names = c("foo", "bar"), xpath = "cond")`. ### New linters diff --git a/R/any_duplicated_linter.R b/R/any_duplicated_linter.R index bb0351a96..04a80bd84 100644 --- a/R/any_duplicated_linter.R +++ b/R/any_duplicated_linter.R @@ -35,8 +35,7 @@ #' @export any_duplicated_linter <- function() { any_duplicated_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'any'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'duplicated']]] /parent::expr[ count(expr) = 2 @@ -87,8 +86,9 @@ any_duplicated_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content + xml_calls <- source_expression$xml_find_function_calls("any") - any_duplicated_expr <- xml_find_all(xml, any_duplicated_xpath) + any_duplicated_expr <- xml_find_all(xml_calls, any_duplicated_xpath) any_duplicated_lints <- xml_nodes_to_lints( any_duplicated_expr, source_expression = source_expression, diff --git a/R/any_is_na_linter.R b/R/any_is_na_linter.R index 1e01ff687..a0ea91e33 100644 --- a/R/any_is_na_linter.R +++ b/R/any_is_na_linter.R @@ -37,8 +37,7 @@ #' @export any_is_na_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'any'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.na']]] /parent::expr[ count(expr) = 2 @@ -47,9 +46,8 @@ any_is_na_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("any") + bad_expr <- xml_find_all(xml_calls, xpath) xml_nodes_to_lints( bad_expr, diff --git a/R/backport_linter.R b/R/backport_linter.R index d4c71866d..3c1eaeaeb 100644 --- a/R/backport_linter.R +++ b/R/backport_linter.R @@ -45,25 +45,28 @@ backport_linter <- function(r_version = getRversion(), except = character()) { backport_index <- rep(names(backport_blacklist), times = lengths(backport_blacklist)) names(backport_index) <- unlist(backport_blacklist) - names_xpath <- "//SYMBOL | //SYMBOL_FUNCTION_CALL" - Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content - all_names_nodes <- xml_find_all(xml, names_xpath) + used_symbols <- xml_find_all(xml, "//SYMBOL") + used_symbols <- used_symbols[xml_text(used_symbols) %in% names(backport_index)] + + all_names_nodes <- combine_nodesets( + source_expression$xml_find_function_calls(names(backport_index)), + used_symbols + ) all_names <- xml_text(all_names_nodes) bad_versions <- unname(backport_index[all_names]) - needs_backport <- !is.na(bad_versions) lint_message <- sprintf( "%s (R %s) is not available for dependency R >= %s.", - all_names[needs_backport], - bad_versions[needs_backport], + all_names, + bad_versions, r_version ) xml_nodes_to_lints( - all_names_nodes[needs_backport], + all_names_nodes, source_expression = source_expression, lint_message = lint_message, type = "warning" diff --git a/R/boolean_arithmetic_linter.R b/R/boolean_arithmetic_linter.R index c6ef4158a..c0d0c755c 100644 --- a/R/boolean_arithmetic_linter.R +++ b/R/boolean_arithmetic_linter.R @@ -35,8 +35,7 @@ boolean_arithmetic_linter <- function() { zero_expr <- "(EQ or NE or GT or LE) and expr[NUM_CONST[text() = '0' or text() = '0L']]" one_expr <- "(LT or GE) and expr[NUM_CONST[text() = '1' or text() = '1L']]" length_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'which' or text() = 'grep'] - /parent::expr + parent::expr /parent::expr /parent::expr[ expr[SYMBOL_FUNCTION_CALL[text() = 'length']] @@ -44,8 +43,7 @@ boolean_arithmetic_linter <- function() { ] ") sum_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'sum'] - /parent::expr + parent::expr /parent::expr[ expr[ expr[SYMBOL_FUNCTION_CALL[text() = 'grepl']] @@ -53,12 +51,14 @@ boolean_arithmetic_linter <- function() { ] and parent::expr[ ({zero_expr}) or ({one_expr})] ] ") - any_xpath <- paste(length_xpath, "|", sum_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - any_expr <- xml_find_all(xml, any_xpath) + length_calls <- source_expression$xml_find_function_calls(c("which", "grep")) + sum_calls <- source_expression$xml_find_function_calls("sum") + any_expr <- c( + xml_find_all(length_calls, length_xpath), + xml_find_all(sum_calls, sum_xpath) + ) xml_nodes_to_lints( any_expr, diff --git a/R/class_equals_linter.R b/R/class_equals_linter.R index 99b7dea56..2dd24b83d 100644 --- a/R/class_equals_linter.R +++ b/R/class_equals_linter.R @@ -35,8 +35,7 @@ #' @export class_equals_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'class'] - /parent::expr + parent::expr /parent::expr /parent::expr[ not(preceding-sibling::OP-LEFT-BRACKET) @@ -45,9 +44,8 @@ class_equals_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("class") + bad_expr <- xml_find_all(xml_calls, xpath) operator <- xml_find_chr(bad_expr, "string(*[2])") lint_message <- sprintf( diff --git a/R/condition_call_linter.R b/R/condition_call_linter.R index 2204d807f..983556869 100644 --- a/R/condition_call_linter.R +++ b/R/condition_call_linter.R @@ -77,16 +77,11 @@ condition_call_linter <- function(display_call = FALSE) { msg_fmt <- "Use %s(., call. = FALSE) not to display the call in an error message." } - xpath <- glue::glue(" - //SYMBOL_FUNCTION_CALL[text() = 'stop' or text() = 'warning'] - /parent::expr[{call_cond}] - /parent::expr - ") + xpath <- glue::glue("parent::expr[{call_cond}]/parent::expr") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(c("stop", "warning")) + bad_expr <- xml_find_all(xml_calls, xpath) xml_nodes_to_lints( bad_expr, diff --git a/R/condition_message_linter.R b/R/condition_message_linter.R index 9f33a6797..e20e53b4b 100644 --- a/R/condition_message_linter.R +++ b/R/condition_message_linter.R @@ -44,9 +44,8 @@ condition_message_linter <- function() { translators <- c("packageStartupMessage", "message", "warning", "stop") xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ - ({xp_text_in_table(translators)}) - and not(preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT) + self::SYMBOL_FUNCTION_CALL[ + not(preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT) ] /parent::expr /following-sibling::expr[ @@ -57,9 +56,8 @@ condition_message_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + 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") bad_expr <- bad_expr[is.na(sep_value) | sep_value %in% c("", " ")] diff --git a/R/conjunct_test_linter.R b/R/conjunct_test_linter.R index 7a920a392..5b4b0ca2b 100644 --- a/R/conjunct_test_linter.R +++ b/R/conjunct_test_linter.R @@ -79,30 +79,21 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE, allow_filter <- match.arg(allow_filter) expect_true_assert_that_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'assert_that'] - /parent::expr + parent::expr /following-sibling::expr[1][AND2] /parent::expr " named_stopifnot_condition <- if (allow_named_stopifnot) "and not(preceding-sibling::*[1][self::EQ_SUB])" else "" stopifnot_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'stopifnot'] - /parent::expr + parent::expr /following-sibling::expr[1][AND2 {named_stopifnot_condition}] /parent::expr ") expect_false_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_false'] - /parent::expr + parent::expr /following-sibling::expr[1][OR2] /parent::expr " - test_xpath <- paste( - expect_true_assert_that_xpath, - stopifnot_xpath, - expect_false_xpath, - sep = " | " - ) filter_ns_cond <- switch(allow_filter, never = "not(SYMBOL_PACKAGE[text() != 'dplyr'])", @@ -110,17 +101,21 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE, always = "true" ) filter_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'filter'] - /parent::expr[{ filter_ns_cond }] + parent::expr[{ filter_ns_cond }] /parent::expr /expr[AND] ") Linter(linter_level = "file", function(source_expression) { # need the full file to also catch usages at the top level - xml <- source_expression$full_xml_parsed_content - - test_expr <- xml_find_all(xml, test_xpath) + expect_true_assert_that_calls <- source_expression$xml_find_function_calls(c("expect_true", "assert_that")) + stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot") + expect_false_calls <- source_expression$xml_find_function_calls("expect_false") + test_expr <- combine_nodesets( + xml_find_all(expect_true_assert_that_calls, expect_true_assert_that_xpath), + xml_find_all(stopifnot_calls, stopifnot_xpath), + xml_find_all(expect_false_calls, expect_false_xpath) + ) matched_fun <- xp_call_name(test_expr) operator <- xml_find_chr(test_expr, "string(expr/*[self::AND2 or self::OR2])") @@ -143,7 +138,8 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE, ) if (allow_filter != "always") { - filter_expr <- xml_find_all(xml, filter_xpath) + xml_calls <- source_expression$xml_find_function_calls("filter") + filter_expr <- xml_find_all(xml_calls, filter_xpath) filter_lints <- xml_nodes_to_lints( filter_expr, diff --git a/R/consecutive_assertion_linter.R b/R/consecutive_assertion_linter.R index c662f8cfa..525edf117 100644 --- a/R/consecutive_assertion_linter.R +++ b/R/consecutive_assertion_linter.R @@ -31,15 +31,14 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export consecutive_assertion_linter <- function() { - xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'stopifnot'] - /parent::expr + stopifnot_xpath <- " + parent::expr /parent::expr[ expr[1]/SYMBOL_FUNCTION_CALL = following-sibling::expr[1]/expr[1]/SYMBOL_FUNCTION_CALL ] - | - //SYMBOL_FUNCTION_CALL[text() = 'assert_that'] - /parent::expr + " + assert_that_xpath <- " + parent::expr /parent::expr[ not(SYMBOL_SUB[text() = 'msg']) and not(following-sibling::expr[1]/SYMBOL_SUB[text() = 'msg']) @@ -49,9 +48,12 @@ consecutive_assertion_linter <- function() { Linter(linter_level = "file", function(source_expression) { # need the full file to also catch usages at the top level - xml <- source_expression$full_xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot") + assert_that_calls <- source_expression$xml_find_function_calls("assert_that") + bad_expr <- combine_nodesets( + xml_find_all(stopifnot_calls, stopifnot_xpath), + xml_find_all(assert_that_calls, assert_that_xpath) + ) matched_function <- xp_call_name(bad_expr) xml_nodes_to_lints( diff --git a/R/consecutive_mutate_linter.R b/R/consecutive_mutate_linter.R index 5aec97fa6..c84403ce0 100644 --- a/R/consecutive_mutate_linter.R +++ b/R/consecutive_mutate_linter.R @@ -37,12 +37,11 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export consecutive_mutate_linter <- function(invalid_backends = "dbplyr") { - attach_pkg_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] - /parent::expr + attach_pkg_xpath <- " + parent::expr /following-sibling::expr /*[self::SYMBOL or self::STR_CONST] - ") + " namespace_xpath <- glue(" //SYMBOL_PACKAGE[{ xp_text_in_table(invalid_backends) }] @@ -75,7 +74,10 @@ consecutive_mutate_linter <- function(invalid_backends = "dbplyr") { # need the full file to also catch usages at the top level xml <- source_expression$full_xml_parsed_content - attach_str <- get_r_string(xml_find_all(xml, attach_pkg_xpath)) + attach_str <- get_r_string(xml_find_all( + source_expression$xml_find_function_calls(c("library", "require")), + attach_pkg_xpath + )) if (any(invalid_backends %in% attach_str)) { return(list()) } diff --git a/R/expect_comparison_linter.R b/R/expect_comparison_linter.R index 134a32734..87dc24169 100644 --- a/R/expect_comparison_linter.R +++ b/R/expect_comparison_linter.R @@ -51,8 +51,7 @@ expect_comparison_linter <- function() { # != doesn't have a clean replacement comparator_nodes <- setdiff(infix_metadata$xml_tag[infix_metadata$comparator], "NE") xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][ {xp_or(comparator_nodes)} ] /parent::expr[not(SYMBOL_SUB[text() = 'info'])] ") @@ -64,9 +63,8 @@ expect_comparison_linter <- function() { ) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("expect_true") + bad_expr <- xml_find_all(xml_calls, xpath) comparator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])") expectation <- comparator_expectation_map[comparator] diff --git a/R/expect_identical_linter.R b/R/expect_identical_linter.R index 6293786f6..4ca6bf04a 100644 --- a/R/expect_identical_linter.R +++ b/R/expect_identical_linter.R @@ -61,8 +61,7 @@ expect_identical_linter <- function() { # where a numeric constant indicates inexact testing is preferable # - skip calls using dots (`...`); see tests expect_equal_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal'] - /parent::expr[not( + parent::expr[not( following-sibling::EQ_SUB or following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'c']] @@ -74,17 +73,18 @@ expect_identical_linter <- function() { /parent::expr " expect_true_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1]/SYMBOL_FUNCTION_CALL[text() = 'identical']] /parent::expr " - xpath <- paste(expect_equal_xpath, "|", expect_true_xpath) - Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + 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( + xml_find_all(expect_equal_calls, expect_equal_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) - bad_expr <- xml_find_all(xml, xpath) xml_nodes_to_lints( bad_expr, source_expression = source_expression, diff --git a/R/expect_length_linter.R b/R/expect_length_linter.R index 7d170d71c..880a66357 100644 --- a/R/expect_length_linter.R +++ b/R/expect_length_linter.R @@ -23,8 +23,7 @@ expect_length_linter <- function() { # TODO(michaelchirico): also catch expect_true(length(x) == 1) xpath <- sprintf(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'length']] and (position() = 1 or preceding-sibling::expr[NUM_CONST]) @@ -33,9 +32,9 @@ expect_length_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + bad_expr <- xml_find_all(xml_calls, xpath) - bad_expr <- xml_find_all(xml, xpath) matched_function <- xp_call_name(bad_expr) lint_message <- sprintf("expect_length(x, n) is better than %s(length(x), n)", matched_function) xml_nodes_to_lints(bad_expr, source_expression, lint_message, type = "warning") diff --git a/R/expect_named_linter.R b/R/expect_named_linter.R index 9d86a9a57..26d83ceb2 100644 --- a/R/expect_named_linter.R +++ b/R/expect_named_linter.R @@ -32,8 +32,7 @@ #' @export expect_named_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'names']] and (position() = 1 or preceding-sibling::expr[STR_CONST]) @@ -42,9 +41,8 @@ expect_named_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + 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) lint_message <- sprintf("expect_named(x, n) is better than %s(names(x), n)", matched_function) diff --git a/R/expect_not_linter.R b/R/expect_not_linter.R index 5c68b80a2..04996d447 100644 --- a/R/expect_not_linter.R +++ b/R/expect_not_linter.R @@ -22,10 +22,10 @@ #' @evalRd rd_tags("expect_not_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -expect_not_linter <- make_linter_from_xpath( +expect_not_linter <- make_linter_from_function_xpath( + function_names = c("expect_true", "expect_false"), xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'expect_false'] - /parent::expr + parent::expr /following-sibling::expr[OP-EXCLAMATION] /parent::expr ", diff --git a/R/expect_null_linter.R b/R/expect_null_linter.R index dd51fa352..10b15ff38 100644 --- a/R/expect_null_linter.R +++ b/R/expect_null_linter.R @@ -40,23 +40,24 @@ expect_null_linter <- function() { # (1) expect_{equal,identical}(x, NULL) (or NULL, x) # (2) expect_true(is.null(x)) expect_equal_identical_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[position() <= 2 and NULL_CONST] /parent::expr " expect_true_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1]/SYMBOL_FUNCTION_CALL[text() = 'is.null']] /parent::expr " - xpath <- paste(expect_equal_identical_xpath, "|", expect_true_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + 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 <- xml_find_all(xml, xpath) + bad_expr <- combine_nodesets( + xml_find_all(expect_equal_identical_calls, expect_equal_identical_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) matched_function <- xp_call_name(bad_expr) msg <- ifelse( diff --git a/R/expect_s3_class_linter.R b/R/expect_s3_class_linter.R index e4051b050..7389b2abc 100644 --- a/R/expect_s3_class_linter.R +++ b/R/expect_s3_class_linter.R @@ -37,8 +37,7 @@ expect_s3_class_linter <- function() { # (1) expect_{equal,identical}(class(x), C) # (2) expect_true(is.(x)) and expect_true(inherits(x, C)) expect_equal_identical_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'class']] and (position() = 1 or preceding-sibling::expr[STR_CONST]) @@ -62,17 +61,19 @@ expect_s3_class_linter <- function() { )) is_class_call <- xp_text_in_table(c(is_s3_class_calls, "inherits")) expect_true_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[ {is_class_call} ]]] /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] ") - xpath <- paste(expect_equal_identical_xpath, "|", expect_true_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + 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 <- xml_find_all(xml, xpath) + bad_expr <- combine_nodesets( + xml_find_all(expect_equal_identical_calls, expect_equal_identical_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) matched_function <- xp_call_name(bad_expr) msg <- ifelse( matched_function %in% c("expect_equal", "expect_identical"), diff --git a/R/expect_s4_class_linter.R b/R/expect_s4_class_linter.R index 4ef021a7e..61e839a97 100644 --- a/R/expect_s4_class_linter.R +++ b/R/expect_s4_class_linter.R @@ -26,19 +26,18 @@ expect_s4_class_linter <- function() { # require 2 expressions because methods::is(x) alone is a valid call, even # though the character output wouldn't make any sense for expect_true(). xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][count(expr) = 3 and expr[1][SYMBOL_FUNCTION_CALL[text() = 'is']]] /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - # TODO(michaelchirico): also catch expect_{equal,identical}(methods::is(x), k). + # TODO(#2423): also catch expect_{equal,identical}(methods::is(x), k). # this seems empirically rare, but didn't check many S4-heavy packages. - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("expect_true") + bad_expr <- xml_find_all(xml_calls, xpath) + xml_nodes_to_lints( bad_expr, source_expression = source_expression, diff --git a/R/expect_true_false_linter.R b/R/expect_true_false_linter.R index 6df426579..c20eb393e 100644 --- a/R/expect_true_false_linter.R +++ b/R/expect_true_false_linter.R @@ -33,16 +33,14 @@ #' @export expect_true_false_linter <- function() { xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[position() <= 2 and NUM_CONST[text() = 'TRUE' or text() = 'FALSE']] /parent::expr " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(c("expect_equal", "expect_identical")) + bad_expr <- xml_find_all(xml_calls, xpath) # NB: use expr/$node, not expr[$node], to exclude other things (especially ns:: parts of the call) call_name <- xp_call_name(bad_expr, condition = "starts-with(text(), 'expect_')") diff --git a/R/expect_type_linter.R b/R/expect_type_linter.R index 17f81c6d1..6d669ed0b 100644 --- a/R/expect_type_linter.R +++ b/R/expect_type_linter.R @@ -43,8 +43,7 @@ expect_type_linter <- function() { ) base_type_tests <- xp_text_in_table(paste0("is.", base_types)) expect_equal_identical_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical'] - /parent::expr + parent::expr /following-sibling::expr[ expr[1][SYMBOL_FUNCTION_CALL[text() = 'typeof']] and (position() = 1 or preceding-sibling::expr[STR_CONST]) @@ -52,17 +51,18 @@ expect_type_linter <- function() { /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label' or text() = 'expected.label'])] " expect_true_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_true'] - /parent::expr + parent::expr /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[ {base_type_tests} ]]] /parent::expr[not(SYMBOL_SUB[text() = 'info' or text() = 'label'])] ") - xpath <- paste(expect_equal_identical_xpath, "|", expect_true_xpath) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + 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( + xml_find_all(expect_equal_identical_calls, expect_equal_identical_xpath), + xml_find_all(expect_true_calls, expect_true_xpath) + ) matched_function <- xp_call_name(bad_expr) msg <- ifelse( matched_function %in% c("expect_equal", "expect_identical"), diff --git a/R/fixed_regex_linter.R b/R/fixed_regex_linter.R index a1798de02..d3a02fc50 100644 --- a/R/fixed_regex_linter.R +++ b/R/fixed_regex_linter.R @@ -76,12 +76,12 @@ #' @export fixed_regex_linter <- function(allow_unescaped = FALSE) { # regular expression pattern is the first argument - pos_1_regex_funs <- xp_text_in_table(c( + pos_1_regex_funs <- c( "grep", "gsub", "sub", "regexec", "grepl", "regexpr", "gregexpr" - )) + ) # regular expression pattern is the second argument - pos_2_regex_funs <- xp_text_in_table(c( + pos_2_regex_funs <- c( # base functions. "strsplit", # data.table functions. @@ -95,7 +95,7 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { "str_remove", "str_remove_all", "str_replace", "str_replace_all", "str_split", "str_starts", "str_subset", "str_view", "str_view_all", "str_which" - )) + ) pipes <- setdiff(magrittr_pipes, c("%$%", "%T>%")) in_pipe_cond <- glue(" @@ -105,9 +105,8 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { # NB: strsplit doesn't have an ignore.case argument # NB: we intentionally exclude cases like gsub(x, c("a" = "b")), where "b" is fixed - xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {pos_1_regex_funs} ] - /parent::expr[ + pos_1_xpath <- glue(" + parent::expr[ not(following-sibling::SYMBOL_SUB[ (text() = 'fixed' or text() = 'ignore.case') and following-sibling::expr[1][NUM_CONST[text() = 'TRUE'] or SYMBOL[text() = 'T']] @@ -124,9 +123,9 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { and preceding-sibling::*[2][self::SYMBOL_SUB/text() = 'pattern'] ) ] - | - //SYMBOL_FUNCTION_CALL[ {pos_2_regex_funs} ] - /parent::expr[ + ") + pos_2_xpath <- glue(" + parent::expr[ not(following-sibling::SYMBOL_SUB[ text() = 'fixed' and following-sibling::expr[1][NUM_CONST[text() = 'TRUE'] or SYMBOL[text() = 'T']] @@ -140,9 +139,12 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - patterns <- xml_find_all(xml, xpath) + 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( + xml_find_all(pos_1_calls, pos_1_xpath), + xml_find_all(pos_2_calls, pos_2_xpath) + ) pattern_strings <- get_r_string(patterns) is_static <- is_not_regex(pattern_strings, allow_unescaped) diff --git a/R/function_return_linter.R b/R/function_return_linter.R index acd95af4d..4a51ecd30 100644 --- a/R/function_return_linter.R +++ b/R/function_return_linter.R @@ -55,10 +55,8 @@ #' @evalRd rd_tags("function_return_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -function_return_linter <- make_linter_from_xpath( - xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'return'] - /parent::expr/parent::expr/expr[LEFT_ASSIGN or RIGHT_ASSIGN] - ", +function_return_linter <- make_linter_from_function_xpath( + function_names = "return", + xpath = "parent::expr/parent::expr/expr[LEFT_ASSIGN or RIGHT_ASSIGN]", lint_message = "Move the assignment outside of the return() clause, or skip assignment altogether." ) diff --git a/R/get_source_expressions.R b/R/get_source_expressions.R index 349b80b99..2d934ea2d 100644 --- a/R/get_source_expressions.R +++ b/R/get_source_expressions.R @@ -18,32 +18,36 @@ #' \describe{ #' \item{expressions}{a `list` of #' `n+1` objects. The first `n` elements correspond to each expression in -#' `filename`, and consist of a list of 9 elements: +#' `filename`, and consist of a list of 8 elements: #' \itemize{ -#' \item{`filename` (`character`)} -#' \item{`line` (`integer`) the line in `filename` where this expression begins} -#' \item{`column` (`integer`) the column in `filename` where this expression begins} +#' \item{`filename` (`character`) the name of the file.} +#' \item{`line` (`integer`) the line in the file where this expression begins.} +#' \item{`column` (`integer`) the column in the file where this expression begins.} #' \item{`lines` (named `character`) vector of all lines spanned by this -#' expression, named with the line number corresponding to `filename`} -#' \item{`parsed_content` (`data.frame`) as given by [utils::getParseData()] for this expression} -#' \item{`xml_parsed_content` (`xml_document`) the XML parse tree of this -#' expression as given by [xmlparsedata::xml_parse_data()]} -#' \item{`content` (`character`) the same as `lines` as a single string (not split across lines)} +#' expression, named with the corresponding line numbers.} +#' \item{`parsed_content` (`data.frame`) as given by [utils::getParseData()] for this expression.} +#' \item{`xml_parsed_content` (`xml_document`) the XML parse tree of this expression as given by +#' [xmlparsedata::xml_parse_data()].} +#' \item{`content` (`character`) the same as `lines` as a single string (not split across lines).} +#' \item{`xml_find_function_calls(function_names)` (`function`) a function that returns all `SYMBOL_FUNCTION_CALL` +#' XML nodes from `xml_parsed_content` with specified function names.} #' } #' #' The final element of `expressions` is a list corresponding to the full file -#' consisting of 6 elements: +#' consisting of 7 elements: #' \itemize{ -#' \item{`filename` (`character`)} -#' \item{`file_lines` (`character`) the [readLines()] output for this file} +#' \item{`filename` (`character`) the name of this file.} +#' \item{`file_lines` (`character`) the [readLines()] output for this file.} #' \item{`content` (`character`) for .R files, the same as `file_lines`; -#' for .Rmd or .qmd scripts, this is the extracted R source code (as text)} +#' for .Rmd or .qmd scripts, this is the extracted R source code (as text).} #' \item{`full_parsed_content` (`data.frame`) as given by -#' [utils::getParseData()] for the full content} +#' [utils::getParseData()] for the full content.} #' \item{`full_xml_parsed_content` (`xml_document`) the XML parse tree of all -#' expressions as given by [xmlparsedata::xml_parse_data()]} +#' expressions as given by [xmlparsedata::xml_parse_data()].} #' \item{`terminal_newline` (`logical`) records whether `filename` has a terminal -#' newline (as determined by [readLines()] producing a corresponding warning)} +#' newline (as determined by [readLines()] producing a corresponding warning).} +#' \item{`xml_find_function_calls(function_names)` (`function`) a function that returns all `SYMBOL_FUNCTION_CALL` +#' XML nodes from `full_xml_parsed_content` with specified function names.} #' } #' } #' \item{error}{A `Lint` object describing any parsing error.} @@ -103,6 +107,7 @@ get_source_expressions <- function(filename, lines = NULL) { ) for (i in seq_along(expressions)) { expressions[[i]]$xml_parsed_content <- expression_xmls[[i]] + expressions[[i]]$xml_find_function_calls <- build_xml_find_function_calls(expression_xmls[[i]]) } } @@ -113,6 +118,7 @@ get_source_expressions <- function(filename, lines = NULL) { content = source_expression$lines, full_parsed_content = parsed_content, full_xml_parsed_content = xml_parsed_content, + xml_find_function_calls = build_xml_find_function_calls(xml_parsed_content), terminal_newline = terminal_newline ) } @@ -476,6 +482,8 @@ get_single_source_expression <- function(loc, lines = expr_lines, parsed_content = pc, xml_parsed_content = xml2::xml_missing(), + # Placeholder for xml_find_function_calls, if needed (e.g. on R <= 4.0.5 with input source "\\") + xml_find_function_calls = build_xml_find_function_calls(xml2::xml_missing()), content = content ) } diff --git a/R/if_not_else_linter.R b/R/if_not_else_linter.R index 9985d7a1e..758ba2102 100644 --- a/R/if_not_else_linter.R +++ b/R/if_not_else_linter.R @@ -71,8 +71,7 @@ if_not_else_linter <- function(exceptions = c("is.null", "is.na", "missing")) { ") ifelse_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /parent::expr[expr[ position() = 2 and OP-EXCLAMATION @@ -85,6 +84,7 @@ if_not_else_linter <- function(exceptions = c("is.null", "is.na", "missing")) { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content + ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs) if_expr <- xml_find_all(xml, if_xpath) if_lints <- xml_nodes_to_lints( @@ -94,7 +94,7 @@ if_not_else_linter <- function(exceptions = c("is.null", "is.na", "missing")) { type = "warning" ) - ifelse_expr <- xml_find_all(xml, ifelse_xpath) + ifelse_expr <- xml_find_all(ifelse_calls, ifelse_xpath) ifelse_call <- xp_call_name(ifelse_expr) ifelse_lints <- xml_nodes_to_lints( ifelse_expr, diff --git a/R/ifelse_censor_linter.R b/R/ifelse_censor_linter.R index ce27eac8a..c43d390e2 100644 --- a/R/ifelse_censor_linter.R +++ b/R/ifelse_censor_linter.R @@ -36,8 +36,7 @@ #' @export ifelse_censor_linter <- function() { xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /following-sibling::expr[ (LT or GT or LE or GE) and expr[1] = following-sibling::expr @@ -47,9 +46,8 @@ ifelse_censor_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs) + bad_expr <- xml_find_all(ifelse_calls, xpath) matched_call <- xp_call_name(bad_expr) operator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])") diff --git a/R/inner_combine_linter.R b/R/inner_combine_linter.R index 9b466a5aa..abba413da 100644 --- a/R/inner_combine_linter.R +++ b/R/inner_combine_linter.R @@ -77,16 +77,14 @@ inner_combine_linter <- function() { lubridate_args_cond ) xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'c'] - /parent::expr[count(following-sibling::expr) > 1] + parent::expr[count(following-sibling::expr) > 1] /following-sibling::expr[1][ {c_expr_cond} ] /parent::expr ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("c") + bad_expr <- xml_find_all(xml_calls, xpath) matched_call <- xp_call_name(bad_expr, depth = 2L) lint_message <- paste( diff --git a/R/keyword_quote_linter.R b/R/keyword_quote_linter.R index 836c7cc1a..f5f52542c 100644 --- a/R/keyword_quote_linter.R +++ b/R/keyword_quote_linter.R @@ -68,8 +68,7 @@ keyword_quote_linter <- function() { ) # SYMBOL_SUB for backticks, STR_CONST for quoted names call_arg_xpath <- glue(" - //SYMBOL_FUNCTION_CALL - /parent::expr + parent::expr /parent::expr /*[(self::SYMBOL_SUB or self::STR_CONST) and {quote_cond}] ") @@ -96,8 +95,9 @@ keyword_quote_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content + xml_calls <- source_expression$xml_find_function_calls(NULL) - call_arg_expr <- xml_find_all(xml, call_arg_xpath) + call_arg_expr <- xml_find_all(xml_calls, call_arg_xpath) invalid_call_quoting <- is_valid_r_name(get_r_string(call_arg_expr)) diff --git a/R/length_levels_linter.R b/R/length_levels_linter.R index f4c2165ba..5dd26207c 100644 --- a/R/length_levels_linter.R +++ b/R/length_levels_linter.R @@ -18,10 +18,10 @@ #' @evalRd rd_tags("length_levels_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -length_levels_linter <- make_linter_from_xpath( +length_levels_linter <- make_linter_from_function_xpath( + function_names = "levels", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'levels'] - /parent::expr + parent::expr /parent::expr /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'length']] ", diff --git a/R/length_test_linter.R b/R/length_test_linter.R index 724b53f0d..ca163ea9a 100644 --- a/R/length_test_linter.R +++ b/R/length_test_linter.R @@ -21,16 +21,15 @@ #' @export length_test_linter <- function() { xpath <- glue::glue(" - //SYMBOL_FUNCTION_CALL[text() = 'length'] - /parent::expr + parent::expr /following-sibling::expr[{ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) }] /parent::expr ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + xml_calls <- source_expression$xml_find_function_calls("length") + bad_expr <- xml_find_all(xml_calls, xpath) - bad_expr <- xml_find_all(xml, xpath) expr_parts <- vapply(lapply(bad_expr, xml_find_all, "expr[2]/*"), xml_text, character(3L)) lint_message <- sprintf( "Checking the length of a logical vector is likely a mistake. Did you mean `length(%s) %s %s`?", diff --git a/R/lengths_linter.R b/R/lengths_linter.R index 69ea9eaa7..1616c4a2d 100644 --- a/R/lengths_linter.R +++ b/R/lengths_linter.R @@ -30,14 +30,8 @@ #' @evalRd rd_tags("lengths_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -lengths_linter <- local({ - loop_funs <- c("sapply", "vapply", "map_int", "map_dbl") - make_linter_from_xpath( - xpath = glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(loop_funs)} ] - /parent::expr - /parent::expr[expr/SYMBOL[text() = 'length']] - "), - lint_message = "Use lengths() to find the length of each element in a list." - ) -}) +lengths_linter <- make_linter_from_function_xpath( + function_names = c("sapply", "vapply", "map_int", "map_dbl"), + xpath = "parent::expr/parent::expr[expr/SYMBOL[text() = 'length']]", + lint_message = "Use lengths() to find the length of each element in a list." +) diff --git a/R/list_comparison_linter.R b/R/list_comparison_linter.R index 02ed9dcd2..8303ff80b 100644 --- a/R/list_comparison_linter.R +++ b/R/list_comparison_linter.R @@ -33,16 +33,14 @@ list_comparison_linter <- function() { # NB: anchor to the comparison expr so that we can easily include the comparator # in the lint message. xpath <- glue(" - //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(names(list_mapper_alternatives)) }] - /parent::expr + parent::expr /parent::expr /parent::expr[{ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) }] ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(names(list_mapper_alternatives)) + bad_expr <- xml_find_all(xml_calls, xpath) list_mapper <- xp_call_name(bad_expr, depth = 2L) diff --git a/R/literal_coercion_linter.R b/R/literal_coercion_linter.R index 734ed85c4..a64e6b426 100644 --- a/R/literal_coercion_linter.R +++ b/R/literal_coercion_linter.R @@ -46,11 +46,11 @@ #' @export literal_coercion_linter <- function() { rlang_coercers <- c("lgl", "int", "dbl", "chr") - coercers <- xp_text_in_table(c( + coercers <- c( # base coercers paste0("as.", c("logical", "integer", "numeric", "double", "character")), rlang_coercers - )) + ) # notes for clarification: # - as.integer(1e6) is arguably easier to read than 1000000L @@ -65,8 +65,7 @@ literal_coercion_linter <- function() { ) " xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {coercers} ] - /parent::expr + parent::expr /parent::expr[ count(expr) = 2 and expr[2][ {not_extraction_or_scientific} ] @@ -74,9 +73,8 @@ literal_coercion_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(coercers) + bad_expr <- xml_find_all(xml_calls, xpath) coercer <- xp_call_name(bad_expr) # tiptoe around the fact that we don't require {rlang} diff --git a/R/make_linter_from_xpath.R b/R/make_linter_from_xpath.R index f539308c7..e707247d9 100644 --- a/R/make_linter_from_xpath.R +++ b/R/make_linter_from_xpath.R @@ -3,6 +3,8 @@ #' @inheritParams xml_nodes_to_lints #' @inheritParams is_lint_level #' @param xpath Character string, an XPath identifying R code to lint. +#' For `make_linter_from_function_xpath()`, the XPath is relative to the `SYMBOL_FUNCTION_CALL` nodes of the +#' selected functions. #' See [xmlparsedata::xml_parse_data()] and [get_source_expressions()]. #' #' @examples @@ -38,3 +40,36 @@ make_linter_from_xpath <- function(xpath, }) } } + +#' @rdname make_linter_from_xpath +#' @param function_names Character vector, names of functions whose calls to examine.. +#' @export +# nolint next: object_length. +make_linter_from_function_xpath <- function(function_names, + xpath, + lint_message, + type = c("warning", "style", "error"), + level = c("expression", "file")) { + type <- match.arg(type) + level <- match.arg(level) + + stopifnot( + "function_names should be a character vector" = is.character(function_names) && length(function_names) > 0L, + "xpath should be a character string" = is.character(xpath) && length(xpath) == 1L && !is.na(xpath) + ) + + function() { + Linter(linter_level = level, function(source_expression) { + call_xml <- source_expression$xml_find_function_calls(function_names) + + expr <- xml_find_all(call_xml, xpath) + + xml_nodes_to_lints( + expr, + source_expression = source_expression, + lint_message = lint_message, + type = type + ) + }) + } +} diff --git a/R/matrix_apply_linter.R b/R/matrix_apply_linter.R index 33a845aa2..fc12ab368 100644 --- a/R/matrix_apply_linter.R +++ b/R/matrix_apply_linter.R @@ -36,8 +36,7 @@ matrix_apply_linter <- function() { # # Currently supported values for MARGIN: scalar numeric and vector of contiguous values created by : (OP-COLON) sums_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'apply'] - /parent::expr + parent::expr /following-sibling::expr[ NUM_CONST or OP-COLON/preceding-sibling::expr[NUM_CONST]/following-sibling::expr[NUM_CONST] and (position() = 2) @@ -52,8 +51,7 @@ matrix_apply_linter <- function() { # Since mean() is a generic, we make sure that we only lint cases with arguments # supported by colMeans() and rowMeans(), i.e., na.rm means_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'apply'] - /parent::expr + parent::expr /following-sibling::expr[ NUM_CONST or OP-COLON/preceding-sibling::expr[NUM_CONST]/following-sibling::expr[NUM_CONST] and (position() = 2) @@ -77,9 +75,8 @@ matrix_apply_linter <- function() { fun_xpath <- "expr[position() = 4]" Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls("apply") + bad_expr <- xml_find_all(xml_calls, xpath) variable <- xml_text(xml_find_all(bad_expr, variable_xpath)) diff --git a/R/missing_argument_linter.R b/R/missing_argument_linter.R index 04da284c6..3565ab5db 100644 --- a/R/missing_argument_linter.R +++ b/R/missing_argument_linter.R @@ -44,16 +44,16 @@ missing_argument_linter <- function(except = c("alist", "quote", "switch"), allo # require >3 children to exclude foo(), which is xpath <- glue(" - //SYMBOL_FUNCTION_CALL[not({ xp_text_in_table(except) })] - /parent::expr + parent::expr /parent::expr[count(*) > 3] /*[{xp_or(conds)}] ") Linter(linter_level = "file", function(source_expression) { - xml <- source_expression$full_xml_parsed_content + xml_targets <- source_expression$xml_find_function_calls(NULL, keep_names = TRUE) + xml_targets <- xml_targets[!names(xml_targets) %in% except] - missing_args <- xml_find_all(xml, xpath) + missing_args <- xml_find_all(xml_targets, xpath) named_idx <- xml_name(missing_args) == "EQ_SUB" arg_id <- character(length(missing_args)) diff --git a/R/missing_package_linter.R b/R/missing_package_linter.R index aac6bda9e..96eb8ba54 100644 --- a/R/missing_package_linter.R +++ b/R/missing_package_linter.R @@ -20,8 +20,7 @@ #' @export missing_package_linter <- function() { library_require_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] - /parent::expr + parent::expr /parent::expr[ expr[2][STR_CONST] or ( @@ -35,17 +34,18 @@ missing_package_linter <- function() { ] " load_require_namespace_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'loadNamespace' or text() = 'requireNamespace'] - /parent::expr + parent::expr /following-sibling::expr[1][STR_CONST] /parent::expr " - call_xpath <- paste(library_require_xpath, "|", load_require_namespace_xpath) Linter(linter_level = "file", function(source_expression) { - xml <- source_expression$full_xml_parsed_content - - pkg_calls <- xml_find_all(xml, call_xpath) + library_require_calls <- source_expression$xml_find_function_calls(c("library", "require")) + load_require_namespace_calls <- source_expression$xml_find_function_calls(c("loadNamespace", "requireNamespace")) + pkg_calls <- combine_nodesets( + xml_find_all(library_require_calls, library_require_xpath), + xml_find_all(load_require_namespace_calls, load_require_namespace_xpath) + ) pkg_names <- get_r_string(xml_find_all( pkg_calls, "OP-LEFT-PAREN[1]/following-sibling::expr[1][SYMBOL | STR_CONST]" diff --git a/R/nested_ifelse_linter.R b/R/nested_ifelse_linter.R index b783f52f5..6441896c5 100644 --- a/R/nested_ifelse_linter.R +++ b/R/nested_ifelse_linter.R @@ -81,15 +81,13 @@ nested_ifelse_linter <- function() { # NB: land on the nested (inner) call, not the outer call, and throw a lint with the inner call's name xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)}] - /parent::expr + parent::expr /following-sibling::expr[expr[1][SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ]]] ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(ifelse_funs) + bad_expr <- xml_find_all(xml_calls, xpath) matched_call <- xp_call_name(bad_expr) lint_message <- paste( diff --git a/R/nrow_subset_linter.R b/R/nrow_subset_linter.R index eb731e579..2e877ce9f 100644 --- a/R/nrow_subset_linter.R +++ b/R/nrow_subset_linter.R @@ -23,10 +23,10 @@ #' @evalRd rd_tags("nrow_subset_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -nrow_subset_linter <- make_linter_from_xpath( +nrow_subset_linter <- make_linter_from_function_xpath( + function_names = "subset", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'subset'] - /parent::expr + parent::expr /parent::expr /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'nrow']] ", diff --git a/R/nzchar_linter.R b/R/nzchar_linter.R index f0073ca9e..8b86a1207 100644 --- a/R/nzchar_linter.R +++ b/R/nzchar_linter.R @@ -68,8 +68,7 @@ nzchar_linter <- function() { # nchar(., type="width") not strictly compatible with nzchar # unsure allowNA compatible, so allow it just in case (see TODO in tests) nchar_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'nchar'] - /parent::expr + parent::expr /parent::expr /parent::expr[ ({ xp_or(comparator_nodes) }) @@ -108,7 +107,8 @@ nzchar_linter <- function() { type = "warning" ) - nchar_expr <- xml_find_all(xml, nchar_xpath) + xml_calls <- source_expression$xml_find_function_calls("nchar") + nchar_expr <- xml_find_all(xml_calls, nchar_xpath) nchar_lints <- xml_nodes_to_lints( nchar_expr, source_expression = source_expression, diff --git a/R/outer_negation_linter.R b/R/outer_negation_linter.R index a68134db4..f9f5a6715 100644 --- a/R/outer_negation_linter.R +++ b/R/outer_negation_linter.R @@ -39,8 +39,7 @@ outer_negation_linter <- function() { # NB: requirement that count(expr)>1 is to prevent any() from linting # e.g. in magrittr pipelines. xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'any' or text() = 'all'] - /parent::expr[following-sibling::expr] + parent::expr[following-sibling::expr] /parent::expr[ not(expr[ position() > 1 @@ -51,9 +50,8 @@ outer_negation_linter <- function() { " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + xml_calls <- source_expression$xml_find_function_calls(c("any", "all")) + bad_expr <- xml_find_all(xml_calls, xpath) matched_call <- xp_call_name(bad_expr) inverse_call <- ifelse(matched_call == "any", "all", "any") diff --git a/R/paste_linter.R b/R/paste_linter.R index 57ebcfb93..094d7e064 100644 --- a/R/paste_linter.R +++ b/R/paste_linter.R @@ -106,15 +106,13 @@ paste_linter <- function(allow_empty_sep = FALSE, check_file_paths <- allow_file_path %in% c("double_slash", "never") paste_sep_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste'] - /parent::expr + parent::expr /following-sibling::SYMBOL_SUB[text() = 'sep' and following-sibling::expr[1][STR_CONST]] /parent::expr " to_string_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste' or text() = 'paste0'] - /parent::expr + parent::expr /parent::expr[ count(expr) = 3 and SYMBOL_SUB[text() = 'collapse']/following-sibling::expr[1][STR_CONST] @@ -122,27 +120,23 @@ paste_linter <- function(allow_empty_sep = FALSE, " paste0_sep_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste0'] - /parent::expr + parent::expr /following-sibling::SYMBOL_SUB[text() = 'sep'] /parent::expr " paste_strrep_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'paste' or text() = 'paste0'] - /parent::expr[ - count(following-sibling::expr) = 2 - and following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'rep']] and expr[2][STR_CONST]] - and following-sibling::SYMBOL_SUB[text() = 'collapse'] - ] - /parent::expr + parent::expr[ + count(following-sibling::expr) = 2 + and following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'rep']] and expr[2][STR_CONST]] + and following-sibling::SYMBOL_SUB[text() = 'collapse'] + ]/parent::expr " # Type II: paste0(x, "/", y, "/", z) # NB: some conditions require evaluating the R string, only a few can be done in pure XPath. See below. paste0_file_path_xpath <- xp_strip_comments(" - //SYMBOL_FUNCTION_CALL[text() = 'paste0'] - /parent::expr + parent::expr /parent::expr[ (: exclude paste0(x) :) count(expr) > 2 @@ -162,14 +156,16 @@ paste_linter <- function(allow_empty_sep = FALSE, 'Note that paste() converts empty inputs to "", whereas file.path() leaves it empty.' Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + 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) optional_lints <- list() # Both of these look for paste(..., sep = "..."), differing in which 'sep' is linted, # so run the expensive XPath search/R parse only once if (!allow_empty_sep || check_file_paths) { - paste_sep_expr <- xml_find_all(xml, paste_sep_xpath) + paste_sep_expr <- xml_find_all(paste_calls, paste_sep_xpath) paste_sep_value <- get_r_string(paste_sep_expr, xpath = "./SYMBOL_SUB[text() = 'sep']/following-sibling::expr[1]") } @@ -184,7 +180,7 @@ paste_linter <- function(allow_empty_sep = FALSE, if (!allow_to_string) { # 3 expr: the function call, the argument, and collapse= - to_string_expr <- xml_find_all(xml, to_string_xpath) + to_string_expr <- xml_find_all(both_calls, to_string_xpath) collapse_value <- get_r_string( to_string_expr, xpath = "./SYMBOL_SUB[text() = 'collapse']/following-sibling::expr[1]" @@ -202,7 +198,7 @@ paste_linter <- function(allow_empty_sep = FALSE, )) } - paste0_sep_expr <- xml_find_all(xml, paste0_sep_xpath) + paste0_sep_expr <- xml_find_all(paste0_calls, paste0_sep_xpath) paste0_sep_lints <- xml_nodes_to_lints( paste0_sep_expr, source_expression = source_expression, @@ -210,7 +206,7 @@ paste_linter <- function(allow_empty_sep = FALSE, type = "warning" ) - paste_strrep_expr <- xml_find_all(xml, paste_strrep_xpath) + paste_strrep_expr <- xml_find_all(both_calls, paste_strrep_xpath) collapse_arg <- get_r_string(paste_strrep_expr, "SYMBOL_SUB/following-sibling::expr[1]/STR_CONST") paste_strrep_expr <- paste_strrep_expr[!nzchar(collapse_arg)] paste_call <- xp_call_name(paste_strrep_expr) @@ -236,7 +232,7 @@ paste_linter <- function(allow_empty_sep = FALSE, type = "warning" )) - paste0_file_path_expr <- xml_find_all(xml, paste0_file_path_xpath) + paste0_file_path_expr <- xml_find_all(paste0_calls, paste0_file_path_xpath) is_file_path <- !vapply(paste0_file_path_expr, check_is_not_file_path, logical(1L), allow_file_path = allow_file_path) optional_lints <- c(optional_lints, xml_nodes_to_lints( diff --git a/R/print_linter.R b/R/print_linter.R index 72b90d66a..438ecc0f5 100644 --- a/R/print_linter.R +++ b/R/print_linter.R @@ -29,10 +29,10 @@ #' @evalRd rd_tags("print_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -print_linter <- make_linter_from_xpath( +print_linter <- make_linter_from_function_xpath( + function_names = "print", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'print'] - /parent::expr + parent::expr /parent::expr[expr[2][ STR_CONST or expr/SYMBOL_FUNCTION_CALL[ diff --git a/R/redundant_ifelse_linter.R b/R/redundant_ifelse_linter.R index 57be2b34c..4c01a3d32 100644 --- a/R/redundant_ifelse_linter.R +++ b/R/redundant_ifelse_linter.R @@ -45,8 +45,7 @@ #' @export redundant_ifelse_linter <- function(allow10 = FALSE) { tf_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /parent::expr[ expr[position() <= 4 and NUM_CONST[text() = 'TRUE']] and expr[position() <= 4 and NUM_CONST[text() = 'FALSE']] @@ -58,8 +57,7 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { ") num_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ] - /parent::expr + parent::expr /parent::expr[ expr[position() <= 4 and NUM_CONST[text() = '1' or text() = '1L']] and expr[position() <= 4 and NUM_CONST[text() = '0' or text() = '0L']] @@ -71,11 +69,11 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + xml_targets <- source_expression$xml_find_function_calls(ifelse_funs) lints <- list() - tf_expr <- xml_find_all(xml, tf_xpath) + tf_expr <- xml_find_all(xml_targets, tf_xpath) matched_call <- xp_call_name(tf_expr) # [1] call; [2] logical condition first_arg <- xml_find_chr(tf_expr, "string(expr[3]/NUM_CONST)") @@ -87,7 +85,7 @@ redundant_ifelse_linter <- function(allow10 = FALSE) { lints <- c(lints, xml_nodes_to_lints(tf_expr, source_expression, tf_message, type = "warning")) if (!allow10) { - num_expr <- xml_find_all(xml, num_xpath) + num_expr <- xml_find_all(xml_targets, num_xpath) matched_call <- xp_call_name(num_expr) # [1] call; [2] logical condition first_arg <- xml_find_chr(num_expr, "string(expr[3]/NUM_CONST)") diff --git a/R/regex_subset_linter.R b/R/regex_subset_linter.R index 556a2beaf..33a9fd8d6 100644 --- a/R/regex_subset_linter.R +++ b/R/regex_subset_linter.R @@ -54,8 +54,7 @@ regex_subset_linter <- function() { # is basically what we need, i.e., whatever expression comes in # [grepl(pattern, )] matches exactly, e.g. names(x)[grepl(ptn, names(x))]. xpath_fmt <- " - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(calls)} ] - /parent::expr + parent::expr /parent::expr[ parent::expr[ OP-LEFT-BRACKET @@ -64,13 +63,12 @@ regex_subset_linter <- function() { and expr[position() = {arg_pos} ] = parent::expr/expr[1] ] " - grep_xpath <- glue(xpath_fmt, calls = c("grepl", "grep"), arg_pos = 3L) - stringr_xpath <- glue(xpath_fmt, calls = c("str_detect", "str_which"), arg_pos = 2L) + grep_xpath <- glue(xpath_fmt, arg_pos = 3L) + stringr_xpath <- glue(xpath_fmt, arg_pos = 2L) Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - grep_expr <- xml_find_all(xml, grep_xpath) + grep_calls <- source_expression$xml_find_function_calls(c("grepl", "grep")) + grep_expr <- xml_find_all(grep_calls, grep_xpath) grep_lints <- xml_nodes_to_lints( grep_expr, @@ -80,7 +78,8 @@ regex_subset_linter <- function() { type = "warning" ) - stringr_expr <- xml_find_all(xml, stringr_xpath) + stringr_calls <- source_expression$xml_find_function_calls(c("str_detect", "str_which")) + stringr_expr <- xml_find_all(stringr_calls, stringr_xpath) stringr_lints <- xml_nodes_to_lints( stringr_expr, diff --git a/R/rep_len_linter.R b/R/rep_len_linter.R index f3eae2e5d..4e0dd583a 100644 --- a/R/rep_len_linter.R +++ b/R/rep_len_linter.R @@ -24,11 +24,11 @@ #' @evalRd rd_tags("rep_len_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -rep_len_linter <- make_linter_from_xpath( +rep_len_linter <- make_linter_from_function_xpath( + function_names = "rep", # count(expr) is for cases using positional matching; see ?rep. xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'rep'] - /parent::expr + parent::expr /parent::expr[ ( SYMBOL_SUB[text() = 'length.out'] diff --git a/R/routine_registration_linter.R b/R/routine_registration_linter.R index 1d0fe2e47..b6f30503f 100644 --- a/R/routine_registration_linter.R +++ b/R/routine_registration_linter.R @@ -31,15 +31,12 @@ #' - #' #' @export -routine_registration_linter <- local({ - native_routine_callers <- c(".C", ".Call", ".Fortran", ".External") - make_linter_from_xpath( - xpath = glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(native_routine_callers)} ] - /parent::expr - /following-sibling::expr[1]/STR_CONST - /parent::expr - "), - lint_message = "Register your native code routines with useDynLib and R_registerRoutines()." - ) -}) +routine_registration_linter <- make_linter_from_function_xpath( + function_names = c(".C", ".Call", ".Fortran", ".External"), + xpath = " + parent::expr + /following-sibling::expr[1]/STR_CONST + /parent::expr + ", + lint_message = "Register your native code routines with useDynLib and R_registerRoutines()." +) diff --git a/R/sample_int_linter.R b/R/sample_int_linter.R index a797f29df..dfdee8d0e 100644 --- a/R/sample_int_linter.R +++ b/R/sample_int_linter.R @@ -39,8 +39,7 @@ sample_int_linter <- function() { # exclude TRUE/FALSE for sample(replace = TRUE, ...) usage. better # would be match.arg() but this also works. xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'sample'] - /parent::expr[not(OP-DOLLAR or OP-AT)] + parent::expr[not(OP-DOLLAR or OP-AT)] /following-sibling::expr[1][ ( expr[1]/NUM_CONST[text() = '1' or text() = '1L'] @@ -66,9 +65,9 @@ sample_int_linter <- function() { ") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + xml_calls <- source_expression$xml_find_function_calls("sample") + bad_expr <- xml_find_all(xml_calls, xpath) - bad_expr <- xml_find_all(xml, xpath) first_call <- xp_call_name(bad_expr, depth = 2L) original <- sprintf("%s(n)", first_call) original[!is.na(xml_find_first(bad_expr, "expr[2]/OP-COLON"))] <- "1:n" diff --git a/R/seq_linter.R b/R/seq_linter.R index 5c4bb6c13..decc02c66 100644 --- a/R/seq_linter.R +++ b/R/seq_linter.R @@ -50,8 +50,7 @@ seq_linter <- function() { # Exact `xpath` depends on whether bad function was used in conjunction with `seq()` seq_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'seq'] - /parent::expr + parent::expr /following-sibling::expr[1][expr/SYMBOL_FUNCTION_CALL[ {bad_funcs} ]] /parent::expr[count(expr) = 2] ") @@ -67,8 +66,6 @@ seq_linter <- function() { ] ") - xpath <- paste(seq_xpath, "|", colon_xpath) - ## The actual order of the nodes is document order ## In practice we need to handle length(x):1 get_fun <- function(expr, n) { @@ -88,8 +85,12 @@ seq_linter <- function() { Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content + seq_calls <- source_expression$xml_find_function_calls("seq") - badx <- xml_find_all(xml, xpath) + badx <- combine_nodesets( + xml_find_all(seq_calls, seq_xpath), + xml_find_all(xml, colon_xpath) + ) dot_expr1 <- get_fun(badx, 1L) dot_expr2 <- get_fun(badx, 2L) diff --git a/R/sort_linter.R b/R/sort_linter.R index 6691f8494..0604b7d23 100644 --- a/R/sort_linter.R +++ b/R/sort_linter.R @@ -83,8 +83,7 @@ sort_linter <- function() { ") sorted_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'sort'] - /parent::expr + parent::expr /parent::expr[not(SYMBOL_SUB)] /parent::expr[ (EQ or NE) @@ -130,7 +129,8 @@ sort_linter <- function() { type = "warning" ) - sorted_expr <- xml_find_all(xml, sorted_xpath) + xml_calls <- source_expression$xml_find_function_calls("sort") + sorted_expr <- xml_find_all(xml_calls, sorted_xpath) sorted_op <- xml_text(xml_find_first(sorted_expr, "*[2]")) lint_message <- ifelse( diff --git a/R/source_utils.R b/R/source_utils.R new file mode 100644 index 000000000..3179847af --- /dev/null +++ b/R/source_utils.R @@ -0,0 +1,23 @@ +#' 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`) +#' +#' @return A fast function to query +#' `xml_find_all(xml, glue::glue("//SYMBOL_FUNCTION_CALL[text() = '{function_names[1]}' or ...]"))`, +#' or, using the internal function `xp_text_in_table()`, +#' `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) + + function(function_names, keep_names = FALSE) { + if (is.null(function_names)) { + res <- function_call_cache + } else { + res <- function_call_cache[names(function_call_cache) %in% function_names] + } + if (keep_names) res else unname(res) + } +} diff --git a/R/sprintf_linter.R b/R/sprintf_linter.R index ac8e7de23..910d147e5 100644 --- a/R/sprintf_linter.R +++ b/R/sprintf_linter.R @@ -28,8 +28,7 @@ #' @export sprintf_linter <- function() { call_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'sprintf' or text() = 'gettextf'] - /parent::expr + parent::expr /parent::expr[ ( OP-LEFT-PAREN/following-sibling::expr[1]/STR_CONST or @@ -105,9 +104,8 @@ sprintf_linter <- function() { } Linter(linter_level = "file", function(source_expression) { - xml <- source_expression$full_xml_parsed_content - - sprintf_calls <- xml_find_all(xml, call_xpath) + xml_calls <- source_expression$xml_find_function_calls(c("sprintf", "gettextf")) + sprintf_calls <- xml_find_all(xml_calls, call_xpath) sprintf_warning <- vapply(sprintf_calls, capture_sprintf_warning, character(1L)) diff --git a/R/stopifnot_all_linter.R b/R/stopifnot_all_linter.R index 7ec01ea3e..499d66e22 100644 --- a/R/stopifnot_all_linter.R +++ b/R/stopifnot_all_linter.R @@ -29,10 +29,10 @@ #' @evalRd rd_tags("stopifnot_all_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -stopifnot_all_linter <- make_linter_from_xpath( +stopifnot_all_linter <- make_linter_from_function_xpath( + function_names = "stopifnot", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'stopifnot'] - /parent::expr + parent::expr /parent::expr /expr[expr/SYMBOL_FUNCTION_CALL[text() = 'all']] ", diff --git a/R/string_boundary_linter.R b/R/string_boundary_linter.R index becc64bec..fe3727b9e 100644 --- a/R/string_boundary_linter.R +++ b/R/string_boundary_linter.R @@ -61,8 +61,7 @@ string_boundary_linter <- function(allow_grepl = FALSE) { "contains(text(), '^') or contains(text(), '$')" ) str_detect_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'str_detect'] - /parent::expr + parent::expr /following-sibling::expr[2] /STR_CONST[ {str_cond} ] ") @@ -74,8 +73,7 @@ string_boundary_linter <- function(allow_grepl = FALSE) { if (!allow_grepl) { grepl_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'grepl'] - /parent::expr + parent::expr /parent::expr[ not(SYMBOL_SUB[ text() = 'ignore.case' @@ -119,8 +117,8 @@ string_boundary_linter <- function(allow_grepl = FALSE) { list(lint_expr = expr[can_replace], lint_type = lint_type) } - substr_xpath_parts <- glue(" - //{ c('EQ', 'NE') } + substr_xpath <- glue(" + (//EQ | //NE) /parent::expr[ expr[STR_CONST] and expr[ @@ -138,7 +136,6 @@ string_boundary_linter <- function(allow_grepl = FALSE) { ] ] ") - substr_xpath <- paste(substr_xpath_parts, collapse = " | ") substr_arg2_xpath <- "string(./expr[expr[1][SYMBOL_FUNCTION_CALL]]/expr[3])" @@ -147,7 +144,10 @@ string_boundary_linter <- function(allow_grepl = FALSE) { lints <- list() - str_detect_lint_data <- get_regex_lint_data(xml, str_detect_xpath) + str_detect_lint_data <- get_regex_lint_data( + source_expression$xml_find_function_calls("str_detect"), + str_detect_xpath + ) str_detect_lint_message <- str_detect_message_map[str_detect_lint_data$lint_type] lints <- c(lints, xml_nodes_to_lints( @@ -158,7 +158,7 @@ string_boundary_linter <- function(allow_grepl = FALSE) { )) if (!allow_grepl) { - grepl_lint_data <- get_regex_lint_data(xml, grepl_xpath) + grepl_lint_data <- get_regex_lint_data(source_expression$xml_find_function_calls("grepl"), grepl_xpath) grepl_lint_message <- grepl_message_map[grepl_lint_data$lint_type] lints <- c(lints, xml_nodes_to_lints( diff --git a/R/strings_as_factors_linter.R b/R/strings_as_factors_linter.R index ae9a3787b..577ab7c74 100644 --- a/R/strings_as_factors_linter.R +++ b/R/strings_as_factors_linter.R @@ -39,7 +39,7 @@ #' @evalRd rd_tags("strings_as_factors_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -strings_as_factors_linter <- function() { +strings_as_factors_linter <- local({ # a call to c() with only literal string inputs, # e.g. c("a") or c("a", "b"), but not c("a", b) c_combine_strings <- " @@ -63,8 +63,7 @@ strings_as_factors_linter <- function() { # (1) above argument is to row.names= # (2) stringsAsFactors is manually supplied (with any value) xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'data.frame'] - /parent::expr + parent::expr /parent::expr[ expr[ ( @@ -82,17 +81,11 @@ strings_as_factors_linter <- function() { ] ") - Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) - - xml_nodes_to_lints( - bad_expr, - source_expression = source_expression, - lint_message = - "Supply an explicit value for stringsAsFactors for this code to work before and after R version 4.0.", - type = "warning" - ) - }) -} + make_linter_from_function_xpath( + function_names = "data.frame", + xpath = xpath, + lint_message = + "Supply an explicit value for stringsAsFactors for this code to work before and after R version 4.0.", + type = "warning" + ) +}) diff --git a/R/system_file_linter.R b/R/system_file_linter.R index 3ff20dfca..24fba540e 100644 --- a/R/system_file_linter.R +++ b/R/system_file_linter.R @@ -25,19 +25,24 @@ #' @seealso [linters] for a complete list of linters available in lintr. #' @export system_file_linter <- function() { - funs <- c("system.file", "file.path") # either system.file(file.path(...)) or file.path(system.file(...)) - xpath_parts <- glue(" - //SYMBOL_FUNCTION_CALL[text() = '{funs}'] - /parent::expr[following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = '{rev(funs)}']] + file_path_xpath <- " + parent::expr[following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'system.file']] /parent::expr - ") - xpath <- paste(xpath_parts, collapse = " | ") + " + system_file_xpath <- " + parent::expr[following-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'file.path']] + /parent::expr + " Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content + file_path_calls <- source_expression$xml_find_function_calls("file.path") + system_file_calls <- source_expression$xml_find_function_calls("system.file") - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- combine_nodesets( + xml_find_all(file_path_calls, file_path_xpath), + xml_find_all(system_file_calls, system_file_xpath) + ) outer_call <- xp_call_name(bad_expr) lint_message <- paste( diff --git a/R/undesirable_function_linter.R b/R/undesirable_function_linter.R index c96604179..762ecda5d 100644 --- a/R/undesirable_function_linter.R +++ b/R/undesirable_function_linter.R @@ -66,7 +66,6 @@ undesirable_function_linter <- function(fun = default_undesirable_functions, } xp_condition <- xp_and( - xp_text_in_table(names(fun)), paste0( "not(parent::expr/preceding-sibling::expr[last()][SYMBOL_FUNCTION_CALL[", xp_text_in_table(c("library", "require")), @@ -76,16 +75,19 @@ undesirable_function_linter <- function(fun = default_undesirable_functions, ) if (symbol_is_undesirable) { - xpath <- glue("//SYMBOL_FUNCTION_CALL[{xp_condition}] | //SYMBOL[{xp_condition}]") - } else { - xpath <- glue("//SYMBOL_FUNCTION_CALL[{xp_condition}]") + symbol_xpath <- glue("//SYMBOL[({xp_text_in_table(names(fun))}) and {xp_condition}]") } - + xpath <- glue("self::SYMBOL_FUNCTION_CALL[{xp_condition}]") Linter(linter_level = "expression", function(source_expression) { xml <- source_expression$xml_parsed_content + xml_calls <- source_expression$xml_find_function_calls(names(fun)) + + matched_nodes <- xml_find_all(xml_calls, xpath) + if (symbol_is_undesirable) { + matched_nodes <- combine_nodesets(matched_nodes, xml_find_all(xml, symbol_xpath)) + } - matched_nodes <- xml_find_all(xml, xpath) fun_names <- get_r_string(matched_nodes) msgs <- vapply( diff --git a/R/unnecessary_concatenation_linter.R b/R/unnecessary_concatenation_linter.R index 092b78b67..ed263bfb1 100644 --- a/R/unnecessary_concatenation_linter.R +++ b/R/unnecessary_concatenation_linter.R @@ -87,8 +87,7 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { # ) } call_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'c'] - /parent::expr + parent::expr /parent::expr[ not(EQ_SUB) and ( {xp_or(zero_arg_cond, one_arg_cond)} ) @@ -97,9 +96,8 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { # num_args_xpath <- "count(./expr) - 1" Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - c_calls <- xml_find_all(xml, call_xpath) + xml_calls <- source_expression$xml_find_function_calls("c") + c_calls <- xml_find_all(xml_calls, call_xpath) # bump count(args) by 1 if inside a pipeline num_args <- as.integer(xml_find_num(c_calls, num_args_xpath)) + diff --git a/R/unnecessary_lambda_linter.R b/R/unnecessary_lambda_linter.R index 3b956d8e2..0ca14d78a 100644 --- a/R/unnecessary_lambda_linter.R +++ b/R/unnecessary_lambda_linter.R @@ -80,20 +80,19 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # call is using positional or keyword arguments -- we can # throw a lint for sweep() lambdas where the following arguments # are all named) but for now it seems like overkill. - apply_funs <- xp_text_in_table(c( # nolint: object_usage_linter. Used in glue call below. + apply_funs <- c( "lapply", "sapply", "vapply", "apply", "tapply", "rapply", "eapply", "dendrapply", "mapply", "by", "outer", "mclapply", "mcmapply", "parApply", "parCapply", "parLapply", "parLapplyLB", "parRapply", "parSapply", "parSapplyLB", "pvec", purrr_mappers - )) + ) # OP-PLUS: condition for complex literal, e.g. 0+2i. # NB: this includes 0+3 and TRUE+FALSE, which are also fine. inner_comparison_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'sapply' or text() = 'vapply'] - /parent::expr + parent::expr /parent::expr /expr[FUNCTION] /expr[ @@ -119,8 +118,7 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # - and it has to be passed positionally (not as a keyword) # d. the function argument doesn't appear elsewhere in the call default_fun_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {apply_funs} ] - /parent::expr + parent::expr /following-sibling::expr[(FUNCTION or OP-LAMBDA) and count(SYMBOL_FORMALS) = 1] /expr[last()][ count(.//SYMBOL[self::* = preceding::SYMBOL_FORMALS[1]]) = 1 @@ -145,8 +143,7 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { # 2. the lone argument marker `.x` or `.` purrr_symbol <- "SYMBOL[text() = '.x' or text() = '.']" purrr_fun_xpath <- glue(" - //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(purrr_mappers)} ] - /parent::expr + parent::expr /following-sibling::expr[ OP-TILDE and expr[OP-LEFT-PAREN/following-sibling::expr[1][not(preceding-sibling::*[2][self::SYMBOL_SUB])]/{purrr_symbol}] @@ -160,9 +157,8 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { symbol_xpath <- "expr[last()]//expr[SYMBOL_FUNCTION_CALL[text() != 'return']]" Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - default_fun_expr <- xml_find_all(xml, default_fun_xpath) + default_calls <- source_expression$xml_find_function_calls(apply_funs) + default_fun_expr <- xml_find_all(default_calls, default_fun_xpath) # TODO(michaelchirico): further message customization is possible here, # e.g. don't always refer to 'lapply()' in the example, and customize to @@ -184,7 +180,8 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { inner_comparison_lints <- NULL if (!allow_comparison) { - inner_comparison_expr <- xml_find_all(xml, inner_comparison_xpath) + sapply_vapply_calls <- source_expression$xml_find_function_calls(c("sapply", "vapply")) + inner_comparison_expr <- xml_find_all(sapply_vapply_calls, inner_comparison_xpath) mapper <- xp_call_name(xml_find_first(inner_comparison_expr, "parent::expr/parent::expr")) if (length(mapper) > 0L) fun_value <- if (mapper == "sapply") "" else ", FUN.VALUE = " @@ -203,7 +200,8 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) { ) } - purrr_fun_expr <- xml_find_all(xml, purrr_fun_xpath) + purrr_calls <- source_expression$xml_find_function_calls(purrr_mappers) + purrr_fun_expr <- xml_find_all(purrr_calls, purrr_fun_xpath) purrr_call_fun <- xml_text(xml_find_first(purrr_fun_expr, fun_xpath)) purrr_symbol <- xml_text(xml_find_first(purrr_fun_expr, symbol_xpath)) diff --git a/R/unused_import_linter.R b/R/unused_import_linter.R index 4850030b4..73dad0b72 100644 --- a/R/unused_import_linter.R +++ b/R/unused_import_linter.R @@ -54,8 +54,7 @@ unused_import_linter <- function(allow_ns_usage = FALSE, } import_xpath <- " - //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] - /parent::expr + parent::expr /parent::expr[ expr[2][STR_CONST] or not(SYMBOL_SUB[ @@ -65,8 +64,8 @@ unused_import_linter <- function(allow_ns_usage = FALSE, ] " + xp_used_functions <- "self::SYMBOL_FUNCTION_CALL[not(preceding-sibling::NS_GET)]" xp_used_symbols <- paste( - "//SYMBOL_FUNCTION_CALL[not(preceding-sibling::NS_GET)]", "//SYMBOL[not( parent::expr/preceding-sibling::expr[last()]/SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require'] )]", @@ -76,8 +75,11 @@ unused_import_linter <- function(allow_ns_usage = FALSE, Linter(linter_level = "file", function(source_expression) { xml <- source_expression$full_xml_parsed_content + library_calls <- source_expression$xml_find_function_calls(c("library", "require")) + all_calls <- source_expression$xml_find_function_calls(NULL) + + import_exprs <- xml_find_all(library_calls, import_xpath) - import_exprs <- xml_find_all(xml, import_xpath) if (length(import_exprs) == 0L) { return(list()) } @@ -86,6 +88,7 @@ unused_import_linter <- function(allow_ns_usage = FALSE, imported_pkgs <- as.character(parse(text = imported_pkgs, keep.source = FALSE)) used_symbols <- unique(c( + xml_text(xml_find_all(all_calls, xp_used_functions)), xml_text(xml_find_all(xml, xp_used_symbols)), extract_glued_symbols(xml, interpret_glue = interpret_glue) )) diff --git a/R/which_grepl_linter.R b/R/which_grepl_linter.R index 72d250911..747f65a7e 100644 --- a/R/which_grepl_linter.R +++ b/R/which_grepl_linter.R @@ -19,10 +19,10 @@ #' @evalRd rd_tags("which_grepl_linter") #' @seealso [linters] for a complete list of linters available in lintr. #' @export -which_grepl_linter <- make_linter_from_xpath( +which_grepl_linter <- make_linter_from_function_xpath( + function_names = "grepl", xpath = " - //SYMBOL_FUNCTION_CALL[text() = 'grepl'] - /parent::expr + parent::expr /parent::expr /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'which']] ", diff --git a/R/xp_utils.R b/R/xp_utils.R index 50b35fc98..621bc13b4 100644 --- a/R/xp_utils.R +++ b/R/xp_utils.R @@ -124,3 +124,15 @@ xpath_comment_re <- rex::rex( ":)" ) xp_strip_comments <- function(xpath) rex::re_substitutes(xpath, xpath_comment_re, "", global = TRUE) + +#' Combine two or more nodesets to a single nodeset +#' +#' Useful for calling `{xml2}` functions on a combined set of nodes obtained using different XPath searches. +#' +#' @noRd +# TODO(r-lib/xml2#433): remove this and just use c() +combine_nodesets <- function(...) { + res <- c(...) + class(res) <- "xml_nodeset" + res +} diff --git a/R/yoda_test_linter.R b/R/yoda_test_linter.R index 56163b4da..1b4b0c671 100644 --- a/R/yoda_test_linter.R +++ b/R/yoda_test_linter.R @@ -47,18 +47,18 @@ yoda_test_linter <- function() { " pipes <- setdiff(magrittr_pipes, c("%$%", "%<>%")) xpath <- glue(" - //SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical' or text() = 'expect_setequal'] - /parent::expr - /following-sibling::expr[1][ {const_condition} ] - /parent::expr[not(preceding-sibling::*[self::PIPE or self::SPECIAL[{ xp_text_in_table(pipes) }]])] + parent::expr + /following-sibling::expr[1][ {const_condition} ] + /parent::expr[not(preceding-sibling::*[self::PIPE or self::SPECIAL[{ xp_text_in_table(pipes) }]])] ") second_const_xpath <- glue("expr[position() = 3 and ({const_condition})]") Linter(linter_level = "expression", function(source_expression) { - xml <- source_expression$xml_parsed_content - - bad_expr <- xml_find_all(xml, xpath) + bad_expr <- xml_find_all( + source_expression$xml_find_function_calls(c("expect_equal", "expect_identical", "expect_setequal")), + xpath + ) matched_call <- xp_call_name(bad_expr) second_const <- xml_find_first(bad_expr, second_const_xpath) diff --git a/man/default_undesirable_functions.Rd b/man/default_undesirable_functions.Rd index 7562e02c8..7c5c9ba63 100644 --- a/man/default_undesirable_functions.Rd +++ b/man/default_undesirable_functions.Rd @@ -28,13 +28,13 @@ Use \code{\link[=modify_defaults]{modify_defaults()}} to produce a custom list. \details{ The following functions are sometimes regarded as undesirable: \itemize{ +\item \code{\link[=.libPaths]{.libPaths()}} As an alternative, use \code{\link[withr:with_libpaths]{withr::with_libpaths()}} for a temporary change instead of permanently modifying the library location. \item \code{\link[=attach]{attach()}} As an alternative, use roxygen2's @importFrom statement in packages, or \code{::} in scripts. \code{\link[=attach]{attach()}} modifies the global search path. \item \code{\link[=browser]{browser()}} As an alternative, remove this likely leftover from debugging. It pauses execution when run. \item \code{\link[=debug]{debug()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution to pause when that function is run. \item \code{\link[=debugcall]{debugcall()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution to pause when that function is run. \item \code{\link[=debugonce]{debugonce()}} As an alternative, remove this likely leftover from debugging. It traps a function and causes execution to pause when that function is run. \item \code{\link[=detach]{detach()}} As an alternative, avoid modifying the global search path. Detaching environments from the search path is rarely necessary in production code. -\item \code{\link[=.libPaths]{.libPaths()}} As an alternative, use \code{\link[withr:with_libpaths]{withr::with_libpaths()}} for a temporary change instead of permanently modifying the library location. \item \code{\link[=library]{library()}} As an alternative, use roxygen2's @importFrom statement in packages and \code{::} in scripts, instead of modifying the global search path. \item \code{\link[=mapply]{mapply()}} As an alternative, use \code{\link[=Map]{Map()}} to guarantee a list is returned and simplify accordingly. \item \code{\link[=options]{options()}} As an alternative, use \code{\link[withr:with_options]{withr::with_options()}} for a temporary change instead of permanently modifying the session options. @@ -55,7 +55,7 @@ The following functions are sometimes regarded as undesirable: The following operators are sometimes regarded as undesirable: \itemize{ \item \code{\link[base:assignOps]{<<-}} As an alternative, It assigns outside the current environment in a way that can be hard to reason about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment with \code{\link[=assign]{assign()}}. Recall that you can create an environment at the desired scope with \code{\link[=new.env]{new.env()}}. -\item \code{\link[base:assignOps]{<<-}} As an alternative, It assigns outside the current environment in a way that can be hard to reason about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment with \code{\link[=assign]{assign()}}. Recall that you can create an environment at the desired scope with \code{\link[=new.env]{new.env()}}. \item \code{\link[base:ns-dblcolon]{:::}} As an alternative, It accesses non-exported functions inside packages. Code relying on these is likely to break in future versions of the package because the functions are not part of the public interface and may be changed or removed by the maintainers without notice. Use public functions via \code{::} instead. +\item \code{\link[base:assignOps]{<<-}} As an alternative, It assigns outside the current environment in a way that can be hard to reason about. Prefer fully-encapsulated functions wherever possible, or, if necessary, assign to a specific environment with \code{\link[=assign]{assign()}}. Recall that you can create an environment at the desired scope with \code{\link[=new.env]{new.env()}}. } } diff --git a/man/get_source_expressions.Rd b/man/get_source_expressions.Rd index d7ab406db..3293f0e31 100644 --- a/man/get_source_expressions.Rd +++ b/man/get_source_expressions.Rd @@ -17,32 +17,36 @@ A \code{list} with three components: \describe{ \item{expressions}{a \code{list} of \code{n+1} objects. The first \code{n} elements correspond to each expression in -\code{filename}, and consist of a list of 9 elements: +\code{filename}, and consist of a list of 8 elements: \itemize{ -\item{\code{filename} (\code{character})} -\item{\code{line} (\code{integer}) the line in \code{filename} where this expression begins} -\item{\code{column} (\code{integer}) the column in \code{filename} where this expression begins} +\item{\code{filename} (\code{character}) the name of the file.} +\item{\code{line} (\code{integer}) the line in the file where this expression begins.} +\item{\code{column} (\code{integer}) the column in the file where this expression begins.} \item{\code{lines} (named \code{character}) vector of all lines spanned by this -expression, named with the line number corresponding to \code{filename}} -\item{\code{parsed_content} (\code{data.frame}) as given by \code{\link[utils:getParseData]{utils::getParseData()}} for this expression} -\item{\code{xml_parsed_content} (\code{xml_document}) the XML parse tree of this -expression as given by \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}} -\item{\code{content} (\code{character}) the same as \code{lines} as a single string (not split across lines)} +expression, named with the corresponding line numbers.} +\item{\code{parsed_content} (\code{data.frame}) as given by \code{\link[utils:getParseData]{utils::getParseData()}} for this expression.} +\item{\code{xml_parsed_content} (\code{xml_document}) the XML parse tree of this expression as given by +\code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}.} +\item{\code{content} (\code{character}) the same as \code{lines} as a single string (not split across lines).} +\item{\code{xml_find_function_calls(function_names)} (\code{function}) a function that returns all \code{SYMBOL_FUNCTION_CALL} +XML nodes from \code{xml_parsed_content} with specified function names.} } The final element of \code{expressions} is a list corresponding to the full file -consisting of 6 elements: +consisting of 7 elements: \itemize{ -\item{\code{filename} (\code{character})} -\item{\code{file_lines} (\code{character}) the \code{\link[=readLines]{readLines()}} output for this file} +\item{\code{filename} (\code{character}) the name of this file.} +\item{\code{file_lines} (\code{character}) the \code{\link[=readLines]{readLines()}} output for this file.} \item{\code{content} (\code{character}) for .R files, the same as \code{file_lines}; -for .Rmd or .qmd scripts, this is the extracted R source code (as text)} +for .Rmd or .qmd scripts, this is the extracted R source code (as text).} \item{\code{full_parsed_content} (\code{data.frame}) as given by -\code{\link[utils:getParseData]{utils::getParseData()}} for the full content} +\code{\link[utils:getParseData]{utils::getParseData()}} for the full content.} \item{\code{full_xml_parsed_content} (\code{xml_document}) the XML parse tree of all -expressions as given by \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}} +expressions as given by \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}}.} \item{\code{terminal_newline} (\code{logical}) records whether \code{filename} has a terminal -newline (as determined by \code{\link[=readLines]{readLines()}} producing a corresponding warning)} +newline (as determined by \code{\link[=readLines]{readLines()}} producing a corresponding warning).} +\item{\code{xml_find_function_calls(function_names)} (\code{function}) a function that returns all \code{SYMBOL_FUNCTION_CALL} +XML nodes from \code{full_xml_parsed_content} with specified function names.} } } \item{error}{A \code{Lint} object describing any parsing error.} diff --git a/man/make_linter_from_xpath.Rd b/man/make_linter_from_xpath.Rd index ec935ef61..a92c69003 100644 --- a/man/make_linter_from_xpath.Rd +++ b/man/make_linter_from_xpath.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/make_linter_from_xpath.R \name{make_linter_from_xpath} \alias{make_linter_from_xpath} +\alias{make_linter_from_function_xpath} \title{Create a linter from an XPath} \usage{ make_linter_from_xpath( @@ -10,9 +11,19 @@ make_linter_from_xpath( type = c("warning", "style", "error"), level = c("expression", "file") ) + +make_linter_from_function_xpath( + function_names, + xpath, + lint_message, + type = c("warning", "style", "error"), + level = c("expression", "file") +) } \arguments{ \item{xpath}{Character string, an XPath identifying R code to lint. +For \code{make_linter_from_function_xpath()}, the XPath is relative to the \code{SYMBOL_FUNCTION_CALL} nodes of the +selected functions. See \code{\link[xmlparsedata:xml_parse_data]{xmlparsedata::xml_parse_data()}} and \code{\link[=get_source_expressions]{get_source_expressions()}}.} \item{lint_message}{The message to be included as the \code{message} @@ -24,6 +35,8 @@ the \code{i}-th lint will be given the \code{i}-th message.} \item{level}{Which level of expression is being tested? \code{"expression"} means an individual expression, while \code{"file"} means all expressions in the current file are available.} + +\item{function_names}{Character vector, names of functions whose calls to examine..} } \description{ Create a linter from an XPath diff --git a/tests/testthat/test-get_source_expressions.R b/tests/testthat/test-get_source_expressions.R index 5d60abfae..917a414ed 100644 --- a/tests/testthat/test-get_source_expressions.R +++ b/tests/testthat/test-get_source_expressions.R @@ -218,7 +218,10 @@ test_that("returned data structure is complete", { for (i in seq_along(lines)) { expr <- exprs$expressions[[i]] - expect_named(expr, c("filename", "line", "column", "lines", "parsed_content", "xml_parsed_content", "content")) + expect_named(expr, c( + "filename", "line", "column", "lines", "parsed_content", "xml_parsed_content", "xml_find_function_calls", + "content" + )) expect_identical(expr$filename, temp_file) expect_identical(expr$line, i) expect_identical(expr$column, 1L) @@ -229,7 +232,8 @@ test_that("returned data structure is complete", { } full_expr <- exprs$expressions[[length(lines) + 1L]] expect_named(full_expr, c( - "filename", "file_lines", "content", "full_parsed_content", "full_xml_parsed_content", "terminal_newline" + "filename", "file_lines", "content", "full_parsed_content", "full_xml_parsed_content", "xml_find_function_calls", + "terminal_newline" )) expect_identical(full_expr$filename, temp_file) expect_identical(full_expr$file_lines, lines_with_attr) @@ -245,6 +249,48 @@ test_that("returned data structure is complete", { expect_identical(exprs$lines, lines_with_attr) }) +test_that("xml_find_function_calls works as intended", { + lines <- c("foo()", "bar()", "foo()", "{ foo(); foo(); bar() }") + temp_file <- withr::local_tempfile(lines = lines) + + exprs <- get_source_expressions(temp_file) + + expect_length(exprs$expressions[[1L]]$xml_find_function_calls("foo"), 1L) + expect_length(exprs$expressions[[1L]]$xml_find_function_calls("bar"), 0L) + expect_identical( + exprs$expressions[[1L]]$xml_find_function_calls("foo"), + xml_find_all(exprs$expressions[[1L]]$xml_parsed_content, "//SYMBOL_FUNCTION_CALL[text() = 'foo']") + ) + + expect_length(exprs$expressions[[2L]]$xml_find_function_calls("foo"), 0L) + expect_length(exprs$expressions[[2L]]$xml_find_function_calls("bar"), 1L) + + expect_length(exprs$expressions[[4L]]$xml_find_function_calls("foo"), 2L) + expect_length(exprs$expressions[[4L]]$xml_find_function_calls("bar"), 1L) + expect_length(exprs$expressions[[4L]]$xml_find_function_calls(c("foo", "bar")), 3L) + + # file-level source expression contains all function calls + expect_length(exprs$expressions[[5L]]$xml_find_function_calls("foo"), 4L) + expect_length(exprs$expressions[[5L]]$xml_find_function_calls("bar"), 2L) + expect_length(exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar")), 6L) + + # Also check order is retained: + expect_identical( + exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar")), + xml_find_all(exprs$expressions[[5L]]$full_xml_parsed_content, "//SYMBOL_FUNCTION_CALL") + ) + + # Check naming and full cache + expect_identical( + exprs$expressions[[5L]]$xml_find_function_calls(NULL), + exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar")) + ) + expect_named( + exprs$expressions[[4L]]$xml_find_function_calls(c("foo", "bar"), keep_names = TRUE), + c("foo", "foo", "bar") + ) +}) + test_that("#1262: xml_parsed_content gets returned as missing even if there's no parsed_content", { tempfile <- withr::local_tempfile(lines = '"\\R"') diff --git a/vignettes/creating_linters.Rmd b/vignettes/creating_linters.Rmd index b967e8029..d4025848e 100644 --- a/vignettes/creating_linters.Rmd +++ b/vignettes/creating_linters.Rmd @@ -256,7 +256,7 @@ expect_lint("blah=1; blah=2", list( list(line_number = 1, column_number = 5), list(line_number = 1, column_number = 13), - ) + ), assignment_linter() ) ``` @@ -274,6 +274,26 @@ and so they've been tested and demonstrated their utility already. extract the string exactly as R will see it. This is especially important to make your logic robust to R-4-style raw strings like `R"-(hello)-"`, which is otherwise difficult to express, for example as an XPath. + * `xml_find_function_calls()`: Whenever your linter needs to query R function calls, + e.g. via the XPath `//SYMBOL_FUNCTION_CALL[text() = 'myfun']`, use this member of + `source_expression` to obtain the function call nodes more efficiently. + Instead of + ```r + xml <- source_expression$xml_parsed_content + xpath <- "//SYMBOL_FUNCTION_CALL[text() = 'myfun']/parent::expr/some/cond" + xml_find_all(xml, xpath) + ``` + use + ```r + xml_calls <- source_expression$xml_find_function_calls("myfun") + call_xpath <- "parent::expr/some/cond" + xml_find_all(xml_calls, call_xpath) + ``` + * `make_linter_from_xpath()` and `make_linter_from_function_xpath()`: Whenever your + linter can be expressed by a static XPath and a static message, use `make_linter_from_xpath()` + or, if the XPath starts with `//SYMBOL_FUNCTION_CALL`, use `make_linter_from_function_xpath()`. + Instead of `make_linter_from_xpath(xpath = "//SYMBOL_FUNCTION_CALL[text() = 'foo' or text() = 'bar']/cond")`, + use `make_linter_from_function_xpath(function_names = c("foo", "bar"), xpath = "cond")`. ## Contributing to `{lintr}`