Add a third fuzzer for @/$ equivalency (#2821)

Author: MichaelChirico

.dev/maybe_fuzz_content.R

@@ -9,7 +9,7 @@ maybe_fuzz_content <- function(file, lines) {
     file.copy(file, new_file, copy.mode = FALSE)
   }
 
-  apply_fuzzers(new_file)
+  apply_fuzzers(new_file, list(function_lambda_fuzzer, pipe_fuzzer, dollar_at_fuzzer))
 
   new_file
 }
@@ -54,16 +54,21 @@ pipe_fuzzer <- simple_swap_fuzzer(
   replacements = c("%>%", "|>")
 )
 
+dollar_at_fuzzer <- simple_swap_fuzzer(
+  \(pd) pd$token %in% c("'$'", "'@'"),
+  replacements = c("$", "@")
+)
+
 # we could also consider just passing any test where no fuzzing takes place,
 #   i.e. letting the other GHA handle whether unfuzzed tests pass as expected.
-apply_fuzzers <- function(f) {
+apply_fuzzers <- function(f, fuzzers) {
   pd <- error_or_parse_data(f)
   if (inherits(pd, "error")) {
     return(invisible())
   }
 
   unedited <- lines <- readLines(f)
-  for (fuzzer in list(function_lambda_fuzzer, pipe_fuzzer)) {
+  for (fuzzer in fuzzers) {
     updated_lines <- fuzzer(pd, lines)
     if (is.null(updated_lines) || identical(unedited, updated_lines)) next # skip some I/O if we can
     writeLines(updated_lines, f)

NEWS.md

@@ -45,6 +45,7 @@
 * `brace_linter()` requires `test_that()`'s `code=` argument to have curly braces (#2292, @MichaelChirico).
 * `fixed_regex_linter()` recognizes usage of the new (R 4.5.0) `grepv()` wrapper of `grep()`; `regex_subset_linter()` also recommends `grepv()` alternatives (#2855, @MichaelChirico).
 * `object_usage_linter()` lints missing packages that may cause false positives (#2872, @AshesITR)
+* New argument `include_s4_slots` for the `xml_find_function_calls()` entry in the `get_source_expressions()` to govern whether calls of the form `s4Obj@fun()` are included in the result (#2820, @MichaelChirico).
 
 ### New linters
 
@@ -76,6 +77,11 @@ files in Windows (#2882, @Bisaloo).
   + `library_call_linter()`
   + `terminal_close_linter()`
   + `unnecessary_lambda_linter()`
+* More consistency on handling `@` extractions (#2820, @MichaelChirico).
+  + `function_left_parentheses_linter()`
+  + `indentation_linter()`
+  + `library_call_linter()`
+  + `missing_argument_linter()`
 
 ## Notes
 

R/function_left_parentheses_linter.R

@@ -47,7 +47,8 @@ function_left_parentheses_linter <- function() { # nolint: object_length.
   #   because it allows the xpath to be the same for both FUNCTION and SYMBOL_FUNCTION_CALL.
   #   Further, write 4 separate XPaths because the 'range_end_xpath' differs for these two nodes.
   bad_line_fun_xpath <- "(//FUNCTION | //OP-LAMBDA)[@line1 != following-sibling::OP-LEFT-PAREN/@line1]"
-  bad_line_call_xpath <- "//SYMBOL_FUNCTION_CALL[@line1 != parent::expr/following-sibling::OP-LEFT-PAREN/@line1]"
+  bad_line_call_xpath <-
+    "(//SYMBOL_FUNCTION_CALL | //SLOT)[@line1 != parent::expr/following-sibling::OP-LEFT-PAREN/@line1]"
   bad_col_fun_xpath <- "(//FUNCTION | //OP-LAMBDA)[
     @line1 = following-sibling::OP-LEFT-PAREN/@line1
     and @col2 != following-sibling::OP-LEFT-PAREN/@col1 - 1

R/indentation_linter.R

@@ -161,15 +161,21 @@ indentation_linter <- function(indent = 2L, hanging_indent_style = c("tidy", "al
         glue("self::{paren_tokens_left}/following-sibling::{paren_tokens_right}/preceding-sibling::*[1]/@line2"),
         glue("
           self::*[{xp_and(paste0('not(self::', paren_tokens_left, ')'))}]
-            /following-sibling::SYMBOL_FUNCTION_CALL
+            /following-sibling::*[
+              self::SYMBOL_FUNCTION_CALL
+              or self::SLOT[parent::expr/following-sibling::OP-LEFT-PAREN]
+            ]
             /parent::expr
             /following-sibling::expr[1]
             /@line2
         "),
         glue("
           self::*[
             {xp_and(paste0('not(self::', paren_tokens_left, ')'))}
-            and not(following-sibling::SYMBOL_FUNCTION_CALL)
+            and not(following-sibling::*[
+              self::SYMBOL_FUNCTION_CALL
+              or self::SLOT[parent::expr/following-sibling::OP-LEFT-PAREN]
+            ])
           ]
             /following-sibling::*[not(self::COMMENT)][1]
             /@line2
@@ -237,20 +243,19 @@ indentation_linter <- function(indent = 2L, hanging_indent_style = c("tidy", "al
     is_hanging <- logical(length(indent_levels))
 
     indent_changes <- xml_find_all(xml, xp_indent_changes)
-    for (change in indent_changes) {
-      change_type <- find_indent_type(change)
-      change_begin <- as.integer(xml_attr(change, "line1")) + 1L
-      change_end <- xml_find_num(change, xp_block_ends)
-      if (isTRUE(change_begin <= change_end)) {
-        to_indent <- seq(from = change_begin, to = change_end)
-        expected_indent_levels[to_indent] <- find_new_indent(
-          current_indent = expected_indent_levels[to_indent],
-          change_type = change_type,
-          indent = indent,
-          hanging_indent = as.integer(xml_attr(change, "col2"))
-        )
-        is_hanging[to_indent] <- change_type == "hanging"
-      }
+    change_types <- vapply(indent_changes, find_indent_type, character(1L))
+    change_begins <- as.integer(xml_attr(indent_changes, "line1")) + 1L
+    change_ends <- xml_find_num(indent_changes, xp_block_ends)
+    col2s <- as.integer(xml_attr(indent_changes, "col2"))
+    for (ii in which(change_begins <= change_ends)) {
+      to_indent <- seq(from = change_begins[ii], to = change_ends[ii])
+      expected_indent_levels[to_indent] <- find_new_indent(
+        current_indent = expected_indent_levels[to_indent],
+        change_type = change_types[ii],
+        indent = indent,
+        hanging_indent = col2s[ii]
+      )
+      is_hanging[to_indent] <- change_types[ii] == "hanging"
     }
 
     in_str_const <- logical(length(indent_levels))

R/library_call_linter.R

@@ -97,7 +97,10 @@ library_call_linter <- function(allow_preamble = TRUE) {
   upfront_call_xpath <- glue("
     //SYMBOL_FUNCTION_CALL[{ attach_call_cond }][last()]
       /preceding::expr
-      /SYMBOL_FUNCTION_CALL[{ unsuppressed_call_cond }][last()]
+      /*[
+        (self::SYMBOL_FUNCTION_CALL or self::SLOT[parent::expr/following-sibling::OP-LEFT-PAREN])
+        and ({ unsuppressed_call_cond })
+      ][last()]
       /following::expr[SYMBOL_FUNCTION_CALL[{ attach_call_cond }]]
       /parent::expr
   ")

R/missing_argument_linter.R

@@ -50,7 +50,7 @@ missing_argument_linter <- function(except = c("alist", "quote", "switch"), allo
   ")
 
   Linter(linter_level = "file", function(source_expression) {
-    xml_targets <- source_expression$xml_find_function_calls(NULL, keep_names = TRUE)
+    xml_targets <- source_expression$xml_find_function_calls(NULL, keep_names = TRUE, include_s4_slots = TRUE)
     xml_targets <- xml_targets[!names(xml_targets) %in% except]
 
     missing_args <- xml_find_all(xml_targets, xpath)

R/source_utils.R

@@ -13,11 +13,26 @@ build_xml_find_function_calls <- function(xml) {
   function_call_cache <- xml_find_all(xml, "//SYMBOL_FUNCTION_CALL/parent::expr")
   names(function_call_cache) <- get_r_string(function_call_cache, "SYMBOL_FUNCTION_CALL")
 
-  function(function_names, keep_names = FALSE) {
+  s4_slot_cache <- xml_find_all(xml, "//SLOT/parent::expr[following-sibling::OP-LEFT-PAREN]")
+  names(s4_slot_cache) <- get_r_string(s4_slot_cache, "SLOT")
+
+  function(function_names, keep_names = FALSE, include_s4_slots = FALSE) {
     if (is.null(function_names)) {
-      res <- function_call_cache
+      if (include_s4_slots) {
+        res <- combine_nodesets(function_call_cache, s4_slot_cache)
+      } else {
+        res <- function_call_cache
+      }
     } else {
-      res <- function_call_cache[names(function_call_cache) %in% function_names]
+      include_function_idx <- names(function_call_cache) %in% function_names
+      if (include_s4_slots) {
+        res <- combine_nodesets(
+          function_call_cache[include_function_idx],
+          s4_slot_cache[names(s4_slot_cache) %in% function_names]
+        )
+      } else {
+        res <- function_call_cache[include_function_idx]
+      }
     }
     if (keep_names) res else unname(res)
   }

tests/testthat/test-any_duplicated_linter.R

@@ -1,3 +1,4 @@
+# nofuzz start
 test_that("any_duplicated_linter skips allowed usages", {
   linter <- any_duplicated_linter()
 
@@ -101,3 +102,4 @@ test_that("any_duplicated_linter catches expression with two types of lint", {
     linter
   )
 })
+# nofuzz end

tests/testthat/test-function_left_parentheses_linter.R

@@ -1,27 +1,27 @@
 test_that("function_left_parentheses_linter skips allowed usages", {
   linter <- function_left_parentheses_linter()
 
-  expect_lint("blah", NULL, linter)
-  expect_lint("print(blah)", NULL, linter)
-  expect_lint('"print"(blah)', NULL, linter)
-  expect_lint("base::print(blah)", NULL, linter)
-  expect_lint('base::"print"(blah)', NULL, linter)
-  expect_lint("base::print(blah, fun(1))", NULL, linter)
-  expect_lint("blah <- function(blah) { }", NULL, linter)
-  expect_lint("(1 + 1)", NULL, linter)
-  expect_lint("( (1 + 1) )", NULL, linter)
-  expect_lint("if (blah) { }", NULL, linter)
-  expect_lint("for (i in j) { }", NULL, linter)
-  expect_lint("1 * (1 + 1)", NULL, linter)
-  expect_lint("!(1 == 1)", NULL, linter)
-  expect_lint("(2 - 1):(3 - 1)", NULL, linter)
-  expect_lint("c(1, 2, 3)[(2 - 1)]", NULL, linter)
-  expect_lint("list(1, 2, 3)[[(2 - 1)]]", NULL, linter)
-  expect_lint("range(10)[(2 - 1):(10 - 1)]", NULL, linter)
-  expect_lint("function(){function(){}}()()", NULL, linter)
-  expect_lint("c(function(){})[1]()", NULL, linter)
-  expect_lint("function(x) (mean(x) + 3)", NULL, linter)
-  expect_lint("\"blah (1)\"", NULL, linter)
+  expect_no_lint("blah", linter)
+  expect_no_lint("print(blah)", linter)
+  expect_no_lint('"print"(blah)', linter)
+  expect_no_lint("base::print(blah)", linter)
+  expect_no_lint('base::"print"(blah)', linter)
+  expect_no_lint("base::print(blah, fun(1))", linter)
+  expect_no_lint("blah <- function(blah) { }", linter)
+  expect_no_lint("(1 + 1)", linter)
+  expect_no_lint("( (1 + 1) )", linter)
+  expect_no_lint("if (blah) { }", linter)
+  expect_no_lint("for (i in j) { }", linter)
+  expect_no_lint("1 * (1 + 1)", linter)
+  expect_no_lint("!(1 == 1)", linter)
+  expect_no_lint("(2 - 1):(3 - 1)", linter)
+  expect_no_lint("c(1, 2, 3)[(2 - 1)]", linter)
+  expect_no_lint("list(1, 2, 3)[[(2 - 1)]]", linter)
+  expect_no_lint("range(10)[(2 - 1):(10 - 1)]", linter)
+  expect_no_lint("function(){function(){}}()()", linter)
+  expect_no_lint("c(function(){})[1]()", linter)
+  expect_no_lint("function(x) (mean(x) + 3)", linter)
+  expect_no_lint('"blah (1)"', linter)
 })
 
 test_that("function_left_parentheses_linter blocks disallowed usages", {
@@ -168,7 +168,7 @@ test_that("it doesn't produce invalid lints", {
 test_that("newline in character string doesn't trigger false positive (#1963)", {
   linter <- function_left_parentheses_linter()
 
-  expect_lint('foo("\n")$bar()', NULL, linter)
+  expect_no_lint('foo("\n")$bar()', linter)
   # also corrected the lint metadata for similar cases
   expect_lint(
     trim_some('
@@ -182,14 +182,27 @@ test_that("newline in character string doesn't trigger false positive (#1963)",
     list(line_number = 3L, column_number = 6L),
     linter
   )
+
+  expect_lint(
+    trim_some('
+      (
+        foo("
+        ")@bar
+        ()
+      )
+    '),
+    # attach to 'b' in '@bar'
+    list(line_number = 3L, column_number = 6L),
+    linter
+  )
 })
 
 test_that("shorthand functions are handled", {
   skip_if_not_r_version("4.1.0")
   linter <- function_left_parentheses_linter()
   fun_lint_msg <- rex::rex("Remove spaces before the left parenthesis in a function definition.")
 
-  expect_lint("blah <- \\(blah) { }", NULL, linter)
-  expect_lint("\\(){\\(){}}()()", NULL, linter)
+  expect_no_lint("blah <- \\(blah) { }", linter)
+  expect_no_lint("\\(){\\(){}}()()", linter)
   expect_lint("test <- \\ (x) { }", fun_lint_msg, linter)
 })

tests/testthat/test-get_source_expressions.R

@@ -255,7 +255,14 @@ test_that("returned data structure is complete", {
 })
 
 test_that("xml_find_function_calls works as intended", {
-  lines <- c("foo()", "bar()", "foo()", "{ foo(); foo(); bar() }")
+  lines <- c(
+    "foo()",
+    "bar()",
+    "foo()",
+    "s4Obj@baz()",
+    "{ foo(); foo(); bar(); s4Obj@baz() }",
+    NULL
+  )
   temp_file <- withr::local_tempfile(lines = lines)
 
   exprs <- get_source_expressions(temp_file)
@@ -270,30 +277,40 @@ test_that("xml_find_function_calls works as intended", {
   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)
+  expect_length(exprs$expressions[[5L]]$xml_find_function_calls("foo"), 2L)
+  expect_length(exprs$expressions[[5L]]$xml_find_function_calls("bar"), 1L)
+  expect_length(exprs$expressions[[5L]]$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)
+  expect_length(exprs$expressions[[6L]]$xml_find_function_calls("foo"), 4L)
+  expect_length(exprs$expressions[[6L]]$xml_find_function_calls("bar"), 2L)
+  expect_length(exprs$expressions[[6L]]$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/parent::expr")
+    exprs$expressions[[6L]]$xml_find_function_calls(c("foo", "bar")),
+    xml_find_all(exprs$expressions[[6L]]$full_xml_parsed_content, "//SYMBOL_FUNCTION_CALL/parent::expr")
   )
 
   # 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"))
+    exprs$expressions[[6L]]$xml_find_function_calls(NULL),
+    exprs$expressions[[6L]]$xml_find_function_calls(c("foo", "bar"))
   )
   expect_named(
-    exprs$expressions[[4L]]$xml_find_function_calls(c("foo", "bar"), keep_names = TRUE),
+    exprs$expressions[[5L]]$xml_find_function_calls(c("foo", "bar"), keep_names = TRUE),
     c("foo", "foo", "bar")
   )
+
+  # include_s4_slots
+  expect_identical(
+    exprs$expressions[[6L]]$xml_find_function_calls(NULL, include_s4_slots = TRUE),
+    exprs$expressions[[6L]]$xml_find_function_calls(c("foo", "bar", "baz"), include_s4_slots = TRUE)
+  )
+  expect_named(
+    exprs$expressions[[5L]]$xml_find_function_calls(NULL, keep_names = TRUE, include_s4_slots = TRUE),
+    c("foo", "foo", "bar", "baz")
+  )
 })
 
 test_that("#1262: xml_parsed_content gets returned as missing even if there's no parsed_content", {