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 <chiricom@google.com>

* fix bad commit

* Update NEWS.md

* Add an upper bound improvement from r-devel

---------

Co-authored-by: Michael Chirico <michaelchirico4@gmail.com>
Co-authored-by: Michael Chirico <chiricom@google.com>

Author: AshesITR

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'

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)

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
 

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,

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,

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"

R/boolean_arithmetic_linter.R

@@ -35,30 +35,30 @@ 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']]
       and parent::expr[ ({zero_expr}) or ({one_expr})]
     ]
   ")
   sum_xpath <- glue("
-  //SYMBOL_FUNCTION_CALL[text() = 'sum']
-    /parent::expr
+  parent::expr
     /parent::expr[
       expr[
         expr[SYMBOL_FUNCTION_CALL[text() = 'grepl']]
         or (EQ or NE or GT or LT or GE or LE)
       ] 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,

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(

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,

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("", " ")]

R/conjunct_test_linter.R

@@ -79,48 +79,43 @@ 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'])",
     not_dplyr = "SYMBOL_PACKAGE[text() = 'dplyr']",
     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,

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(

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())
     }

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]