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 <[email protected]>

* fix bad commit

* Update NEWS.md

* Add an upper bound improvement from r-devel

---------

Co-authored-by: Michael Chirico <[email protected]>
Co-authored-by: Michael Chirico <[email protected]>

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