Add a fifth fuzzer for '='/'<-' equivalency

.dev/ast_fuzz_test.R

@@ -61,10 +61,10 @@ writeLines(contents, expect_lint_file)
 # Not useful in CI but good when running locally.
 withr::defer({
   writeLines(original, expect_lint_file)
-  pkgload::load_all()
+  suppressMessages(pkgload::load_all())
 })
 
-pkgload::load_all()
+suppressMessages(pkgload::load_all())
 
 # beware lazy eval: originally tried adding a withr::defer() in each iteration, but
 #   this effectively only runs the last 'defer' expression as the names are only
@@ -125,33 +125,42 @@ for (test_file in list.files("tests/testthat", pattern = "^test-", full.names =
 }
 withr::defer(for (restoration in test_restorations) writeLines(restoration$lines, restoration$file))
 
-# for some reason, 'report <- test_dir(...)' did not work -- the resulting object is ~empty.
-#   even 'report <- test_local(...)', which does return an object, lacks any information about
-#   which tests failed (all reports are about successful or skipped tests). probably this is not
-#   the best approach but documentation was not very helpful.
-reporter <- testthat::SummaryReporter$new()
+# ListReporter pretty essential here -- many other reporters fail to record the information we want,
+#   and/or are overly verbose & reporting all the known-false-positive failures, unsuppressably.
+reporter <- testthat::ListReporter$new()
 testthat::test_local(reporter = reporter, stop_on_failure = FALSE)
 
-failures <- reporter$failures$as_list()
+all_classes <- unlist(lapply(
+  reporter$get_results(),
+  \(test) lapply(test$results, \(x) class(x)[1L])
+))
+cat("Summary of test statuses:\n")
+print(table(all_classes))
+
 # ignore any test that failed for expected reasons, e.g. some known lint metadata changes
 #   about line numbers or the contents of the line. this saves us having to pepper tons of
 #   'nofuzz' comments throughout the suite, as well as getting around the difficulty of injecting
 #   'expect_lint()' with new code to ignore these attributes (this latter we might explore later).
-valid_failure <- vapply(
-  failures,
-  function(failure) {
+invalid_failures <- list()
+for (test in reporter$get_results()) {
+  current_file <- test$file
+  for (res in test$results) {
+    if (!inherits(res, "expectation_failure")) next
+
     # line_number is for the comment injection fuzzer, which adds newlines.
-    if (grepl("(column_number|ranges|line|line_number) .* did not match", failure$message)) {
-      return(TRUE)
-    }
-    FALSE
-  },
-  logical(1L)
-)
-failures <- failures[!valid_failure]
-if (length(failures) > 0L) {
-  names(failures) <- vapply(failures, `[[`, "test", FUN.VALUE = character(1L))
+    if (grepl("(column_number|ranges|line|line_number) .* did not match", res$message)) next
+    res$file <- current_file
+    invalid_failures <- c(invalid_failures, list(res))
+  }
+}
+
+if (length(invalid_failures) > 0L) {
+  names(invalid_failures) <- vapply(
+    invalid_failures,
+    \(x) sprintf("%s:%s", x$file, x$test),
+    character(1L)
+  )
   cat("Some fuzzed tests failed unexpectedly!\n")
-  print(failures)
+  print(invalid_failures)
   stop("Use # nofuzz [start|end] to mark false positives or fix any bugs.")
 }

.dev/maybe_fuzz_content.R

@@ -9,7 +9,13 @@ maybe_fuzz_content <- function(file, lines) {
     file.copy(file, new_file, copy.mode = FALSE)
   }
 
-  apply_fuzzers(new_file, list(function_lambda_fuzzer, pipe_fuzzer, dollar_at_fuzzer, comment_injection_fuzzer))
+  apply_fuzzers(new_file, fuzzers = list(
+    function_lambda_fuzzer,
+    pipe_fuzzer,
+    dollar_at_fuzzer,
+    comment_injection_fuzzer,
+    assignment_fuzzer
+  ))
 
   new_file
 }
@@ -59,6 +65,11 @@ dollar_at_fuzzer <- simple_swap_fuzzer(
   replacements = c("$", "@")
 )
 
+assignment_fuzzer <- simple_swap_fuzzer(
+  \(pd) (pd$token == "LEFT_ASSIGN" & pd$text == "<-") | pd$token == "EQ_ASSIGN",
+  replacements = c("<-", "=")
+)
+
 comment_injection_fuzzer <- function(pd, lines) {
   # injecting comment before a call often structurally breaks parsing
   #   (SYMBOL_FUNCTION_CALL-->SYMBOL), so avoid

NEWS.md

@@ -16,6 +16,7 @@
 
 * `Lint()`, and thus all linters, ensures that the returned object's `message` attribute is consistently a simple character string (and not, for example, an object of class `"glue"`; #2740, @MichaelChirico).
 * Files with encoding inferred from settings read more robustly under `lint(parse_settings = TRUE)` (#2803, @MichaelChirico).
+* `repeat_linter()` no longer errors when `while` is in a column to the right of `}` (#2828, @MichaelChirico).
 
 ## New and improved features
 
@@ -62,7 +63,9 @@
    + `unnecessary_placeholder_linter()`
    + `unreachable_code_linter()` #2827
    + `vector_logic_linter()` #2826
-
+* Assignment with `=` and `<-` are treated as equivalent in more places (#2829, @MichaelChirico). Affected linters are:
+   + `object_overwrite_linter()`
+   + `package_hooks_linter()`
 
 ### New linters
 
@@ -72,7 +75,7 @@
 
 * `unnecessary_nesting_linter()`:
    + Treats function bodies under the shorthand lambda (`\()`) the same as normal function bodies (#2748, @MichaelChirico).
-   + Treats `=` assignment the same as `<-` when deciding to combine consecutive `if()` clauses (#2245, @MichaelChirico).
+   + Treats `=` assignment the same as `<-` for several pieces of logic (#2245 and #2829, @MichaelChirico).
 
 * `unnecessary_nesting_linter()` treats function bodies under the shorthand lambda (`\()`) the same as normal function bodies (#2748, @MichaelChirico).
 * `string_boundary_linter()` omits lints of patterns like `\\^` which have an anchor but are not regular expressions (#2636, @MichaelChirico).

R/object_overwrite_linter.R

@@ -75,9 +75,10 @@ object_overwrite_linter <- function(
 
   # test that the symbol doesn't match an argument name in the function
   # NB: data.table := has parse token LEFT_ASSIGN as well
+  # ancestor::* for '=' assignment
   xpath_assignments <- glue("
     (//SYMBOL | //STR_CONST)[
-      not(text() = ancestor::expr/preceding-sibling::SYMBOL_FORMALS/text())
+      not(text() = ancestor::*/preceding-sibling::SYMBOL_FORMALS/text())
     ]/
       parent::expr[
         count(*) = 1

R/package_hooks_linter.R

@@ -84,7 +84,8 @@ package_hooks_linter <- function() {
   #   exiting early if not.
   any_hook_xpath <- glue("(//FUNCTION | //OP-LAMBDA)/parent::expr/preceding-sibling::expr/SYMBOL[{ns_calls}]")
 
-  hook_xpath <- sprintf("string(./ancestor::expr/expr/SYMBOL[%s])", ns_calls)
+  # * for '=' assignment
+  hook_xpath <- sprintf("string(./ancestor::*/expr/SYMBOL[%s])", ns_calls)
 
   load_arg_name_xpath <- "
   (//FUNCTION | //OP-LAMBDA)

R/repeat_linter.R

@@ -20,7 +20,7 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 repeat_linter <- function() {
-  xpath <- "//WHILE[following-sibling::expr[1]/NUM_CONST[text() = 'TRUE']]"
+  xpath <- "//WHILE[following-sibling::expr[1]/NUM_CONST[text() = 'TRUE']]/parent::expr"
 
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
@@ -30,9 +30,7 @@ repeat_linter <- function() {
     xml_nodes_to_lints(
       lints,
       source_expression = source_expression,
-      lint_message = "Use 'repeat' instead of 'while (TRUE)' for infinite loops.",
-      range_start_xpath = "number(./@col1)",
-      range_end_xpath = "number(./following-sibling::*[3]/@col2)"
+      lint_message = "Use 'repeat' instead of 'while (TRUE)' for infinite loops."
     )
   })
 }

R/unnecessary_nesting_linter.R

@@ -183,7 +183,7 @@ unnecessary_nesting_linter <- function(
 
   used_exit_call_xpath <- glue("expr/expr[position() = last()]/{exit_call_expr}")
 
-  assignment_cond <- if (allow_assignment) "expr[LEFT_ASSIGN or RIGHT_ASSIGN]" else "false"
+  assignment_cond <- if (allow_assignment) "*[LEFT_ASSIGN or RIGHT_ASSIGN or EQ_ASSIGN]" else "false"
 
   # several carve-outs of common cases where single-expression braces are OK
   #   - control flow statements: if, for, while, repeat
@@ -203,7 +203,7 @@ unnecessary_nesting_linter <- function(
   unnecessary_brace_xpath <- glue("
   //OP-LEFT-BRACE
     /parent::expr[
-      count(expr) = 1
+      count(*) - count(COMMENT) - count(OP-LEFT-BRACE) - count(OP-RIGHT-BRACE) = 1
       and not(preceding-sibling::*[
         self::FUNCTION
         or self::OP-LAMBDA
@@ -241,7 +241,10 @@ unnecessary_nesting_linter <- function(
   # "un-walk" from the unnecessary IF to the IF with which it should be combined
   corresponding_if_xpath <- "preceding-sibling::IF | parent::expr/preceding-sibling::IF"
 
-  unnecessary_else_brace_xpath <- "//IF/parent::expr[parent::expr[preceding-sibling::ELSE and count(expr) = 1]]"
+  unnecessary_else_brace_xpath <- "
+  //IF/parent::expr[parent::expr[
+    preceding-sibling::ELSE and count(*) - count(COMMENT) - count(OP-LEFT-BRACE) - count(OP-RIGHT-BRACE) = 1
+  ]]"
 
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content

tests/testthat/test-assignment_linter.R

@@ -1,3 +1,4 @@
+# nofuzz start
 test_that("assignment_linter skips allowed usages", {
   linter <- assignment_linter()
 
@@ -66,7 +67,7 @@ test_that("arguments handle <<- and ->/->> correctly", {
   )
 })
 
-test_that("arguments handle trailing assignment operators correctly", { # nofuzz
+test_that("arguments handle trailing assignment operators correctly", {
   linter_default <- assignment_linter()
   linter_no_trailing <- assignment_linter(allow_trailing = FALSE)
   expect_no_lint("x <- y", linter_no_trailing)
@@ -165,7 +166,7 @@ test_that("arguments handle trailing assignment operators correctly", { # nofuzz
   )
 })
 
-test_that("allow_trailing interacts correctly with comments in braced expressions", { # nofuzz
+test_that("allow_trailing interacts correctly with comments in braced expressions", {
   linter <- assignment_linter(allow_trailing = FALSE)
   expect_no_lint(
     trim_some("
@@ -390,3 +391,4 @@ test_that("implicit '<-' assignments inside calls are ignored where top-level '<
   expect_no_lint("for (i in foo(idx <- is.na(y))) which(idx)", linter)
   expect_no_lint("for (i in foo(bar(idx <- is.na(y)))) which(idx)", linter)
 })
+# nofuzz end

tests/testthat/test-cache.R

@@ -406,30 +406,30 @@ test_that("find_new_line returns the correct line if it is after the current lin
 
 #
 
-test_that("lint with cache uses the provided relative cache directory", {
+test_that("lint with cache uses the provided relative cache directory", { # nofuzz
   path <- withr::local_tempdir("my_cache_dir")
   linter <- assignment_linter()
 
   # create the cache
-  expect_lint("a <- 1", NULL, linter, cache = path)
+  expect_no_lint("a <- 1", linter, cache = path)
   expect_true(dir.exists(path))
   expect_length(list.files(file.path(path)), 1L)
 
   # read the cache
-  expect_lint("a <- 1", NULL, linter, cache = path)
+  expect_no_lint("a <- 1", linter, cache = path)
   expect_true(dir.exists(path))
 })
 
-test_that("it works outside of a package", {
+test_that("it works outside of a package", { # nofuzz
   linter <- assignment_linter()
 
   local_mocked_bindings(find_package = function(...) NULL)
   path <- withr::local_tempfile(pattern = "my_cache_dir_")
   expect_false(dir.exists(path))
-  expect_lint("a <- 1", NULL, linter, cache = path)
+  expect_no_lint("a <- 1", linter, cache = path)
   expect_true(dir.exists(path))
   expect_length(list.files(path), 1L)
-  expect_lint("a <- 1", NULL, linter, cache = path)
+  expect_no_lint("a <- 1", linter, cache = path)
   expect_true(dir.exists(path))
 })
 

tests/testthat/test-coalesce_linter.R

@@ -47,7 +47,7 @@ test_that("coalesce_linter blocks simple disallowed usage", {
   )
 })
 
-test_that("coalesce_linter blocks usage with implicit assignment", {
+test_that("coalesce_linter blocks usage with implicit assignment", { # nofuzz
   linter <- coalesce_linter()
   lint_msg <- rex::rex("Use x %||% y instead of if (is.null(x))")
   lint_msg_not <- rex::rex("Use x %||% y instead of if (!is.null(x))")
@@ -63,7 +63,7 @@ test_that("coalesce_linter blocks usage with implicit assignment", {
   expect_lint("if (!is.null(s <- foo(x))) { s } else { y }", lint_msg_not, linter)
 })
 
-test_that("lints vectorize", {
+test_that("lints vectorize", { # nofuzz
   expect_lint(
     trim_some("{
       if (is.null(x)) y else x

tests/testthat/test-exclusions.R

@@ -56,7 +56,7 @@ test_that("it gives the expected error message when there is mismatch between mu
   )
 })
 
-test_that("partial matching works for exclusions but warns if no linter found", {
+test_that("partial matching works for exclusions but warns if no linter found", { # nofuzz
   lintr:::read_settings(NULL)
 
   expect_warning(
@@ -153,7 +153,7 @@ test_that("#1442: is_excluded_files works if no global exclusions are specified"
   expect_length(lint_dir(tmp), 3L)
 })
 
-test_that("next-line exclusion works", {
+test_that("next-line exclusion works", { # nofuzz
   withr::local_options(
     lintr.exclude = "# NL",
     lintr.exclude_next = "# NLN",
@@ -163,30 +163,27 @@ test_that("next-line exclusion works", {
   linter <- assignment_linter()
 
   # blanket exclusion works
-  expect_lint(
+  expect_no_lint(
     trim_some("
       # NLN
       x = 1
     "),
-    NULL,
     linter
   )
 
   # specific exclusion works
-  expect_lint(
+  expect_no_lint(
     trim_some("
       # NLN: assignment_linter.
       x = 1
     "),
-    NULL,
     linter
   )
-  expect_lint(
+  expect_no_lint(
     trim_some("
       # NLN: assignment.
       x = 1
     "),
-    NULL,
     linter
   )
   expect_lint(

tests/testthat/test-expect_lint.R

@@ -2,6 +2,7 @@
 # thus less than ideal to test expect_lint(), which can process multiple lints. If you want to test
 # for failure, always put the lint check or lint field that must fail first.
 
+# nofuzz start
 linter <- assignment_linter()
 lint_msg <- "Use one of <-, <<- for assignment, not ="
 
@@ -84,3 +85,4 @@ test_that("execution without testthat gives the right errors", {
   expect_error(expect_no_lint(), lint_msg("expect_no_lint"))
   expect_error(expect_lint_free(), lint_msg("expect_lint_free"))
 })
+# nofuzz end

tests/testthat/test-function_return_linter.R

@@ -1,11 +1,12 @@
+# nofuzz start
 test_that("function_return_linter skips allowed usages", {
   lines_simple <- trim_some("
     foo <- function(x) {
       x <- x + 1
       return(x)
     }
   ")
-  expect_lint(lines_simple, NULL, function_return_linter())
+  expect_no_lint(lines_simple, function_return_linter())
 
   # arguably an expression as complicated as this should also be assigned,
   #   but for now that's out of the scope of this linter
@@ -17,7 +18,7 @@ test_that("function_return_linter skips allowed usages", {
       }])
     }
   ")
-  expect_lint(lines_subassignment, NULL, function_return_linter())
+  expect_no_lint(lines_subassignment, function_return_linter())
 })
 
 test_that("function_return_linter blocks simple disallowed usages", {
@@ -96,3 +97,4 @@ test_that("lints vectorize", {
     function_return_linter()
   )
 })
+# nofuzz end

tests/testthat/test-implicit_assignment_linter.R

@@ -1,3 +1,4 @@
+# nofuzz start
 test_that("implicit_assignment_linter skips allowed usages", {
   linter <- implicit_assignment_linter()
 
@@ -503,3 +504,4 @@ test_that("call-less '(' mentions avoiding implicit printing", {
     linter
   )
 })
+# nofuzz end

tests/testthat/test-lint.R

@@ -104,7 +104,7 @@ test_that("lint() results do not depend on the position of the .lintr", {
   )
 })
 
-test_that("lint uses linter names", {
+test_that("lint uses linter names", { # nofuzz
   expect_lint(
     "a = 2",
     list(linter = "bla"),