New parameter 'land_on' to xml_find_function_calls()

R/any_duplicated_linter.R

@@ -34,14 +34,13 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 any_duplicated_linter <- function() {
-  any_duplicated_xpath <- "
-  parent::expr
-    /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'duplicated']]]
-    /parent::expr[
+  any_duplicated_xpath <- "self::expr[
+    expr[2]/expr[1]/SYMBOL_FUNCTION_CALL[text() = 'duplicated']
+    and (
       count(expr) = 2
       or (count(expr) = 3 and SYMBOL_SUB[text() = 'na.rm'])
-    ]
-  "
+    )
+  ]"
 
   # outline:
   #   EQ/NE/GT/LT: ensure we're in a comparison clause
@@ -86,7 +85,7 @@ 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")
+    xml_calls <- source_expression$xml_find_function_calls("any", land_on = "call_expr")
 
     any_duplicated_expr <- xml_find_all(xml_calls, any_duplicated_xpath)
     any_duplicated_lints <- xml_nodes_to_lints(

R/any_is_na_linter.R

@@ -36,20 +36,20 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 any_is_na_linter <- function() {
-  any_xpath <- "
-  parent::expr
-    /following-sibling::expr[1][expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.na']]]
-    /parent::expr[
+  any_xpath <- "self::expr[
+    expr[2]/expr[1]/SYMBOL_FUNCTION_CALL[text() = 'is.na']
+    and (
       count(expr) = 2
       or (count(expr) = 3 and SYMBOL_SUB[text() = 'na.rm'])
-    ]
+    )
+  ]
   "
 
   in_xpath <- "//SPECIAL[text() = '%in%']/preceding-sibling::expr[NUM_CONST[starts-with(text(), 'NA')]]"
 
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
-    xml_calls <- source_expression$xml_find_function_calls("any")
+    xml_calls <- source_expression$xml_find_function_calls("any", land_on = "call_expr")
 
     any_expr <- xml_find_all(xml_calls, any_xpath)
     any_lints <- xml_nodes_to_lints(

R/boolean_arithmetic_linter.R

@@ -32,29 +32,28 @@
 boolean_arithmetic_linter <- function() {
   # TODO(#1580): sum() cases x %in% y, A [&|] B, !A, is.na/is.nan/is.finite/is.infinite/is.element
   # TODO(#1581): extend to include all()-alike expressions
-  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']]"
+  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("
-  parent::expr
-    /parent::expr
+  self::expr
     /parent::expr[
-      expr[SYMBOL_FUNCTION_CALL[text() = 'length']]
+      expr/SYMBOL_FUNCTION_CALL[text() = 'length']
       and parent::expr[ ({zero_expr}) or ({one_expr})]
     ]
   ")
   sum_xpath <- glue("
-  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})]
+  self::expr[
+    expr[
+      expr/SYMBOL_FUNCTION_CALL[text() = 'grepl']
+      or ({ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) })
     ]
+    and parent::expr[ ({zero_expr}) or ({one_expr})]
+  ]
   ")
 
   Linter(linter_level = "expression", function(source_expression) {
-    length_calls <- source_expression$xml_find_function_calls(c("which", "grep"))
-    sum_calls <- source_expression$xml_find_function_calls("sum")
+    length_calls <- source_expression$xml_find_function_calls(c("which", "grep"), land_on = "call_expr")
+    sum_calls <- source_expression$xml_find_function_calls("sum", land_on = "call_expr")
     any_expr <- c(
       xml_find_all(length_calls, length_xpath),
       xml_find_all(sum_calls, sum_xpath)

R/class_equals_linter.R

@@ -35,16 +35,15 @@
 #' @export
 class_equals_linter <- function() {
   xpath <- "
-  parent::expr
-    /parent::expr
+  self::expr
     /parent::expr[
       not(preceding-sibling::OP-LEFT-BRACKET)
       and (EQ or NE or SPECIAL[text() = '%in%'])
     ]
   "
 
   Linter(linter_level = "expression", function(source_expression) {
-    xml_calls <- source_expression$xml_find_function_calls("class")
+    xml_calls <- source_expression$xml_find_function_calls("class", land_on = "call_expr")
     bad_expr <- xml_find_all(xml_calls, xpath)
 
     operator <- xml_find_chr(bad_expr, "string(*[2])")

R/condition_call_linter.R

@@ -57,11 +57,11 @@
 #' @export
 condition_call_linter <- function(display_call = FALSE) {
   call_xpath <- glue::glue("
-    following-sibling::SYMBOL_SUB[text() = 'call.']
+    SYMBOL_SUB[text() = 'call.']
       /following-sibling::expr[1]
       /NUM_CONST[text() = '{!display_call}']
   ")
-  no_call_xpath <- "parent::expr[not(SYMBOL_SUB[text() = 'call.'])]"
+  no_call_xpath <- "not(SYMBOL_SUB[text() = 'call.'])"
 
   if (is.na(display_call)) {
     call_cond <- no_call_xpath
@@ -77,10 +77,10 @@ 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("parent::expr[{call_cond}]/parent::expr")
+  xpath <- glue::glue("self::expr[{call_cond}]")
 
   Linter(linter_level = "expression", function(source_expression) {
-    xml_calls <- source_expression$xml_find_function_calls(c("stop", "warning"))
+    xml_calls <- source_expression$xml_find_function_calls(c("stop", "warning"), land_on = "call_expr")
     bad_expr <- xml_find_all(xml_calls, xpath)
 
     xml_nodes_to_lints(

R/conjunct_test_linter.R

@@ -79,20 +79,14 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE,
   allow_filter <- match.arg(allow_filter)
 
   expect_true_assert_that_xpath <- "
-  parent::expr
-    /following-sibling::expr[1][AND2]
-    /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("
-  parent::expr
-    /following-sibling::expr[1][AND2 {named_stopifnot_condition}]
-    /parent::expr
+    following-sibling::expr[1][AND2 {named_stopifnot_condition}]/parent::expr
   ")
   expect_false_xpath <- "
-  parent::expr
-    /following-sibling::expr[1][OR2]
-    /parent::expr
+    following-sibling::expr[1][OR2]/parent::expr
   "
 
   filter_ns_cond <- switch(allow_filter,
@@ -101,16 +95,17 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE,
     always = "true"
   )
   filter_xpath <- glue("
-  parent::expr[{ filter_ns_cond }]
+  self::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
-    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")
+    expect_true_assert_that_calls <-
+      source_expression$xml_find_function_calls(c("expect_true", "assert_that"), land_on = "call_symbol_expr")
+    stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot", land_on = "call_symbol_expr")
+    expect_false_calls <- source_expression$xml_find_function_calls("expect_false", land_on = "call_symbol_expr")
     test_expr <- combine_nodesets(
       xml_find_all(expect_true_assert_that_calls, expect_true_assert_that_xpath),
       xml_find_all(stopifnot_calls, stopifnot_xpath),
@@ -138,7 +133,7 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE,
     )
 
     if (allow_filter != "always") {
-      xml_calls <- source_expression$xml_find_function_calls("filter")
+      xml_calls <- source_expression$xml_find_function_calls("filter", land_on = "call_symbol_expr")
       filter_expr <- xml_find_all(xml_calls, filter_xpath)
 
       filter_lints <- xml_nodes_to_lints(

R/consecutive_assertion_linter.R

@@ -35,14 +35,12 @@ consecutive_assertion_linter <- function() {
   next_expr <- "following-sibling::*[self::expr or self::expr_or_assign_or_help or self::equal_assign][1]"
 
   stopifnot_xpath <- glue("
-  parent::expr
-    /parent::expr[
+    self::expr[
       expr[1]/SYMBOL_FUNCTION_CALL = {next_expr}/expr[1]/SYMBOL_FUNCTION_CALL
     ]
   ")
   assert_that_xpath <- glue("
-  parent::expr
-    /parent::expr[
+    self::expr[
       not(SYMBOL_SUB[text() = 'msg'])
       and not(following-sibling::expr[1]/SYMBOL_SUB[text() = 'msg'])
       and expr[1]/SYMBOL_FUNCTION_CALL = {next_expr}/expr[1]/SYMBOL_FUNCTION_CALL
@@ -51,8 +49,8 @@ consecutive_assertion_linter <- function() {
 
   Linter(linter_level = "file", function(source_expression) {
     # need the full file to also catch usages at the top level
-    stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot")
-    assert_that_calls <- source_expression$xml_find_function_calls("assert_that")
+    stopifnot_calls <- source_expression$xml_find_function_calls("stopifnot", land_on = "call_expr")
+    assert_that_calls <- source_expression$xml_find_function_calls("assert_that", land_on = "call_expr")
     bad_expr <- combine_nodesets(
       xml_find_all(stopifnot_calls, stopifnot_xpath),
       xml_find_all(assert_that_calls, assert_that_xpath)

R/get_source_expressions.R

@@ -16,44 +16,54 @@
 #'   If `NULL`, then `filename` will be read.
 #' @return A `list` with three components:
 #' \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 8 elements:
-#'   \itemize{
-#'     \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 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 7 elements:
-#'   \itemize{
-#'     \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).}
-#'     \item{`full_parsed_content` (`data.frame`) as given by
-#'           [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()].}
-#'     \item{`terminal_newline` (`logical`) records whether `filename` has a terminal
-#'           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{expressions}{a `list` of `n+1` objects. The first `n` elements correspond to each expression in
+#'     `filename`, and the last element corresponds to the full file. See sections on source expressions.}
 #'   \item{error}{A `Lint` object describing any parsing error.}
 #'   \item{lines}{The [readLines()] output for this file.}
 #' }
 #'
+#' @details
+#' # Source expressions
+#'
+#' The `expressions` objects come in two flavors: one for each expression in a file, the other for
+#'   the entire file. They are very similar but differ in important ways. Expression-level objects
+#'   are better for caching (since expressions change less often than whole files), but some lints
+#'   cannot be expressed at the expression level. A precise description follows:
+#'
+#' ## Expresion-level objects
+#'
+#' These correspond to each top-level expression in the file and consist of a list of 8 elements:
+#'  * `filename` (`character`) the name of the file.
+#'  * `line` (`integer`) the line in the file where this expression begins.
+#'  * `column` (`integer`) the column in the file where this expression begins.
+#'  * `lines` (named `character`) vector of all lines spanned by this expression,
+#'    named with the corresponding line numbers.
+#'  * `parsed_content` (`data.frame`) as given by [utils::getParseData()] for this expression.
+#'  * `xml_parsed_content` (`xml_document`) the XML parse tree of this expression
+#'    as given by [xmlparsedata::xml_parse_data()].
+#'  * `content` (`character`) the same as `lines` as a single string (not split across lines).
+#'  * `xml_find_function_calls(function_names, keep_names, land_on)` (`function`) a function for quickly
+#'    accessing cached function calls in the XML tree. There are three parameters:
+#'     * `function_names` (`character`, default `NULL`) The function(s) to return. `NULL` means all functions.
+#'     * `keep_names` (`logical`, default `FALSE`) Whether to associate each item with the associated function name.
+#'     * `land_on` (`character`, default `"call_symbol"`) Where in the tree should the returned object land?
+#'       The default is to land on the `<SYMBOL_FUNCTION_CALL>` node; `"call_symbol_expr"` gives the `parent::expr`
+#'       of this node, and `"call_expr"` gives the `parent::expr/parent::expr` of this node.
+#'
+#' ## File-level objects
+#'
+#' These encompass the entire file at once and consist of a list of 7 elements:
+#'
+#'  * `filename` (`character`) the name of this file.
+#'  * `file_lines` (`character`) the [readLines()] output for this file.
+#'  * `content` (`character`) for .R files, the same as `file_lines`;
+#'    for .Rmd or .qmd scripts, this is the extracted R source code (as text).
+#'  * `full_parsed_content` (`data.frame`) Same as expression-level `parsed_content`, for the whole file.
+#'  * `full_xml_parsed_content` (`xml_document`) Same as expression-level `xml_parsed_content`, for the whole file.
+#'  * `terminal_newline` (`logical`) records whether `filename` has a terminal
+#'    newline (as determined by [readLines()] producing a corresponding warning).
+#'  * `xml_find_function_calls(function_names, keep_names, land_on)` (`function`) Same as in expression level object.
+#'
 #' @examplesIf requireNamespace("withr", quietly = TRUE)
 #' tmp <- withr::local_tempfile(lines = c("x <- 1", "y <- x + 1"))
 #' get_source_expressions(tmp)

R/source_utils.R

@@ -12,12 +12,18 @@ 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) {
+  function(function_names, keep_names = FALSE, land_on = c("call_symbol", "call_symbol_expr", "call_expr")) {
+    land_on <- match.arg(land_on)
     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)
+    if (!keep_names) res <- unname(res)
+    switch(land_on,
+      call_symbol = res,
+      call_symbol_expr = xml_find_first(res, "parent::expr"),
+      call_expr = xml_find_first(res, "parent::expr/parent::expr")
+    )
   }
 }