Add a fuzzer for injecting comments

.dev/ast_fuzz_test.R

@@ -34,6 +34,30 @@ writeLines(
   ),
   expect_lint_file
 )
+
+# Ensure the fuzzed contents are always visible to facilitate backing out which fuzzed content is at issue
+contents <- readLines(expect_lint_file)
+wrong_number_def_idx <- grep('wrong_number_fmt <- "got %d lints instead of %d%s"', contents, fixed = TRUE)
+wrong_number_use_idx <- grep("sprintf(wrong_number_fmt,", contents, fixed = TRUE)
+if (
+  length(wrong_number_def_idx) != 1L ||
+    length(wrong_number_use_idx) == 0L ||
+    # these lines should be self-contained, have no comments, no nested calls
+    !all(grepl("[^)][)]$", contents[wrong_number_use_idx])) ||
+    inherits(tryCatch(parse(text = contents[wrong_number_use_idx]), error = identity), "error")
+) {
+  stop(sprintf(
+    "Please update this workflow -- need wrong_number_fmt to be easily replaced in file '%s'.",
+    expect_lint_file
+  ))
+}
+
+contents[wrong_number_def_idx] <-
+  'wrong_number_fmt <- "got %d lints instead of %d%s\\nFile contents:\\n%s"'
+contents[wrong_number_use_idx] <-
+  gsub("\\)$", ", readChar(file, file.size(file)))", contents[wrong_number_use_idx])
+writeLines(contents, expect_lint_file)
+
 # Not useful in CI but good when running locally.
 withr::defer({
   writeLines(original, expect_lint_file)
@@ -105,7 +129,7 @@ withr::defer(for (restoration in test_restorations) writeLines(restoration$lines
 #   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()
+reporter <- testthat::SummaryReporter$new(max_reports = 500L)
 testthat::test_local(reporter = reporter, stop_on_failure = FALSE)
 
 failures <- reporter$failures$as_list()
@@ -116,7 +140,8 @@ failures <- reporter$failures$as_list()
 valid_failure <- vapply(
   failures,
   function(failure) {
-    if (grepl("(column_number|ranges|line) .* did not match", failure$message)) {
+    # 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

.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, list(function_lambda_fuzzer, pipe_fuzzer, dollar_at_fuzzer))
+  apply_fuzzers(new_file, list(function_lambda_fuzzer, pipe_fuzzer, dollar_at_fuzzer, comment_injection_fuzzer))
 
   new_file
 }
@@ -59,6 +59,34 @@ dollar_at_fuzzer <- simple_swap_fuzzer(
   replacements = c("$", "@")
 )
 
+comment_injection_fuzzer <- function(pd, lines) {
+  # injecting comment before a call often structurally breaks parsing
+  #   (SYMBOL_FUNCTION_CALL-->SYMBOL), so avoid
+  terminal_token_idx <- which(pd$terminal & !pd$token %in% c("COMMENT", "SYMBOL_FUNCTION_CALL", "SLOT"))
+  # formula is messy because it's very easy to break parsing, but not easy to exclude the right
+  #   elements from the pd data.frame (easier with XPath ancestor axis). Just skip for now.
+  if (any(pd$token == "'~'")) {
+    return(invisible())
+  }
+  injection_count <- sample(0:length(terminal_token_idx), 1L)
+
+  if (injection_count == 0L) {
+    return(invisible())
+  }
+
+  terminal_token_idx <- sort(sample(terminal_token_idx, injection_count))
+
+  for (ii in rev(terminal_token_idx)) {
+    line <- lines[pd$line2[ii]]
+    lines[pd$line2[ii]] <- paste0(
+      substr(line, 1L, pd$col2[ii]),
+      " # INJECTED COMMENT\n",
+      substr(line, pd$col2[ii] + 1L, nchar(line))
+    )
+  }
+  lines
+}
+
 # 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, fuzzers) {

NEWS.md

@@ -10,6 +10,43 @@
 
 * Excluding `cyclocomp_linter()` in `available_linters()` or `linters_with_tags()`, which requires the weak dependency {cyclocomp}, no longer emits a warning (#2909, @MichaelChirico).
 
+## New and improved features
+
+### Linter improvements
+
+* General handling of logic around where comments can appear in code has been improved (#2822, @MichaelChirico). In many cases, this is a tiny robustness fix for weird edge cases unlikely to be found in practice, but in others, this improves practical linter precision (reduced false positives and/or false negatives). The affected linters (with annotations for changes noteworthy enough to have gotten a dedicated bug) are:
+   + `brace_linter()`
+   + `coalesce_linter()`
+   + `comparison_negation_linter()` #2826
+   + `conjunct_test_linter()` #2827
+   + `empty_assignment_linter()`
+   + `expect_comparison_linter()`
+   + `fixed_regex_linter()` #2827
+   + `if_switch_linter()`
+   + `ifelse_censor_linter()` #2826
+   + `implicit_assignment_linter()`
+   + `length_test_linter()`
+   + `literal_coercion_linter()` #2824
+   + `matrix_apply_linter()` #2825
+   + `nzchar_linter()` #2826
+   + `object_length_linter()` #2827
+   + `object_name_linter()` #2827
+   + `object_usage_linter()`
+   + `outer_negation_linter()` #2827
+   + `redundant_equals_linter()`
+   + `regex_subset_linter()`
+   + `seq_linter()`
+   + `sort_linter()`
+   + `sprintf_linter()` #2827
+   + `string_boundary_linter()`
+   + `strings_as_factors_linter()`
+   + `unnecessary_concatenation_linter()` #2827
+   + `unnecessary_lambda_linter()` #2827
+   + `unnecessary_nesting_linter()` #2827
+   + `unnecessary_placeholder_linter()`
+   + `unreachable_code_linter()` #2827
+   + `vector_logic_linter()` #2826
+
 ## Notes
 
 * {lintr} now requires R 4.1.0

R/expect_lint.R

@@ -60,7 +60,8 @@ expect_lint <- function(content, checks, ..., file = NULL, language = "en", igno
   wrong_number_fmt <- "got %d lints instead of %d%s"
   if (is.null(checks)) {
     if (n_lints != 0L) {
-      return(testthat::fail(sprintf(wrong_number_fmt, n_lints, 0L, lint_str)))
+      fail_msg <- sprintf(wrong_number_fmt, n_lints, 0L, lint_str)
+      return(testthat::fail(fail_msg))
     }
     return(testthat::succeed())
   }
@@ -71,7 +72,8 @@ expect_lint <- function(content, checks, ..., file = NULL, language = "en", igno
   checks[] <- lapply(checks, fix_names, "message")
 
   if (n_lints != length(checks)) {
-    return(testthat::fail(sprintf(wrong_number_fmt, n_lints, length(checks), lint_str)))
+    fail_msg <- sprintf(wrong_number_fmt, n_lints, length(checks), lint_str)
+    return(testthat::fail(fail_msg))
   }
 
   if (ignore_order) {

tests/testthat/test-assignment_linter.R

@@ -66,7 +66,7 @@ test_that("arguments handle <<- and ->/->> correctly", {
   )
 })
 
-test_that("arguments handle trailing assignment operators correctly", {
+test_that("arguments handle trailing assignment operators correctly", { # nofuzz
   linter_default <- assignment_linter()
   linter_no_trailing <- assignment_linter(allow_trailing = FALSE)
   expect_no_lint("x <- y", linter_no_trailing)
@@ -165,7 +165,7 @@ test_that("arguments handle trailing assignment operators correctly", {
   )
 })
 
-test_that("allow_trailing interacts correctly with comments in braced expressions", {
+test_that("allow_trailing interacts correctly with comments in braced expressions", { # nofuzz
   linter <- assignment_linter(allow_trailing = FALSE)
   expect_no_lint(
     trim_some("

tests/testthat/test-commas_linter.R

@@ -1,14 +1,15 @@
+# nofuzz start
 test_that("returns the correct linting (with default parameters)", {
   linter <- commas_linter()
   msg_after <- rex::rex("Put a space after a comma.")
   msg_before <- rex::rex("Remove spaces before a comma.")
 
-  expect_lint("blah", NULL, linter)
-  expect_lint("fun(1, 1)", NULL, linter)
-  expect_lint("fun(1,\n  1)", NULL, linter)
-  expect_lint("fun(1,\n1)", NULL, linter)
-  expect_lint("fun(1\n,\n1)", NULL, linter)
-  expect_lint("fun(1\n  ,\n1)", NULL, linter)
+  expect_no_lint("blah", linter)
+  expect_no_lint("fun(1, 1)", linter)
+  expect_no_lint("fun(1,\n  1)", linter)
+  expect_no_lint("fun(1,\n1)", linter)
+  expect_no_lint("fun(1\n,\n1)", linter)
+  expect_no_lint("fun(1\n  ,\n1)", linter)
 
   expect_lint("fun(1\n,1)", msg_after, linter)
   expect_lint("fun(1,1)", msg_after, linter)
@@ -25,14 +26,14 @@ test_that("returns the correct linting (with default parameters)", {
     linter
   )
 
-  expect_lint("\"fun(1 ,1)\"", NULL, linter)
-  expect_lint("a[1, , 2]", NULL, linter)
-  expect_lint("a[1, , 2, , 3]", NULL, linter)
+  expect_no_lint('"fun(1 ,1)"', linter)
+  expect_no_lint("a[1, , 2]", linter)
+  expect_no_lint("a[1, , 2, , 3]", linter)
 
-  expect_lint("switch(op, x = foo, y = bar)", NULL, linter)
-  expect_lint("switch(op, x = , y = bar)", NULL, linter)
-  expect_lint("switch(op, \"x\" = , y = bar)", NULL, linter)
-  expect_lint("switch(op, x = ,\ny = bar)", NULL, linter)
+  expect_no_lint("switch(op, x = foo, y = bar)", linter)
+  expect_no_lint("switch(op, x = , y = bar)", linter)
+  expect_no_lint('switch(op, "x" = , y = bar)', linter)
+  expect_no_lint("switch(op, x = ,\ny = bar)", linter)
 
   expect_lint("switch(op, x = foo , y = bar)", msg_before, linter)
   expect_lint("switch(op, x = foo , y = bar)", msg_before, linter)
@@ -55,8 +56,8 @@ test_that("returns the correct linting (with default parameters)", {
   expect_lint(
     "fun(op    ,bar)",
     list(
-      list(message = msg_before, column_number = 7L, ranges = list(c(7L, 10L))),
-      list(message = msg_after, column_number = 12L, ranges = list(c(12L, 12L)))
+      list(msg_before, column_number = 7L, ranges = list(c(7L, 10L))),
+      list(msg_after, column_number = 12L, ranges = list(c(12L, 12L)))
     ),
     linter
   )
@@ -67,14 +68,14 @@ test_that("returns the correct linting (with 'allow_trailing' set)", {
   msg_after <- rex::rex("Put a space after a comma.")
   msg_before <- rex::rex("Remove spaces before a comma.")
 
-  expect_lint("blah", NULL, linter)
-  expect_lint("fun(1, 1)", NULL, linter)
-  expect_lint("fun(1,\n  1)", NULL, linter)
-  expect_lint("fun(1,\n1)", NULL, linter)
-  expect_lint("fun(1\n,\n1)", NULL, linter)
-  expect_lint("fun(1\n  ,\n1)", NULL, linter)
-  expect_lint("a[1,]", NULL, linter)
-  expect_lint("a(1,)", NULL, linter)
+  expect_no_lint("blah", linter)
+  expect_no_lint("fun(1, 1)", linter)
+  expect_no_lint("fun(1,\n  1)", linter)
+  expect_no_lint("fun(1,\n1)", linter)
+  expect_no_lint("fun(1\n,\n1)", linter)
+  expect_no_lint("fun(1\n  ,\n1)", linter)
+  expect_no_lint("a[1,]", linter)
+  expect_no_lint("a(1,)", linter)
 
   expect_lint("fun(1\n,1)", msg_after, linter)
   expect_lint("fun(1,1)", msg_after, linter)
@@ -88,15 +89,15 @@ test_that("returns the correct linting (with 'allow_trailing' set)", {
     linter
   )
 
-  expect_lint("\"fun(1 ,1)\"", NULL, linter)
-  expect_lint("a[1, , 2]", NULL, linter)
-  expect_lint("a[1, , 2, , 3]", NULL, linter)
-  expect_lint("a[[1,]]", NULL, linter)
+  expect_no_lint('"fun(1 ,1)"', linter)
+  expect_no_lint("a[1, , 2]", linter)
+  expect_no_lint("a[1, , 2, , 3]", linter)
+  expect_no_lint("a[[1,]]", linter)
 
-  expect_lint("switch(op, x = foo, y = bar)", NULL, linter)
-  expect_lint("switch(op, x = , y = bar)", NULL, linter)
-  expect_lint("switch(op, \"x\" = , y = bar)", NULL, linter)
-  expect_lint("switch(op, x = ,\ny = bar)", NULL, linter)
+  expect_no_lint("switch(op, x = foo, y = bar)", linter)
+  expect_no_lint("switch(op, x = , y = bar)", linter)
+  expect_no_lint('switch(op, "x" = , y = bar)', linter)
+  expect_no_lint("switch(op, x = ,\ny = bar)", linter)
 
   expect_lint("switch(op, x = foo , y = bar)", msg_before, linter)
   expect_lint("switch(op, x = foo , y = bar)", msg_before, linter)
@@ -107,9 +108,10 @@ test_that("returns the correct linting (with 'allow_trailing' set)", {
   expect_lint(
     "fun(op    ,bar)",
     list(
-      list(message = msg_before, column_number = 7L, ranges = list(c(7L, 10L))),
-      list(message = msg_after, column_number = 12L, ranges = list(c(12L, 12L)))
+      list(msg_before, column_number = 7L, ranges = list(c(7L, 10L))),
+      list(msg_after, column_number = 12L, ranges = list(c(12L, 12L)))
     ),
     linter
   )
 })
+# nofuzz end

tests/testthat/test-exclusions.R

@@ -71,7 +71,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
   withr::local_dir(test_path("dummy_projects", "project"))
 
   expect_warning(

tests/testthat/test-expect_lint.R

@@ -33,7 +33,7 @@ test_that("single check", {
   expect_success(expect_lint("1:nrow(x)", "(nrow)", seq_linter()))
 })
 
-test_that("multiple checks", {
+test_that("multiple checks", { # nofuzz
   expect_success(
     expect_lint(file = "exclusions-test", checks = as.list(rep(lint_msg, 9L)), linters = linter, parse_settings = FALSE)
   )
@@ -85,7 +85,7 @@ test_that("execution without testthat gives the right errors", {
   expect_error(expect_lint_free(), lint_msg("expect_lint_free"))
 })
 
-test_that("lint order can be ignored", {
+test_that("lint order can be ignored", { # nofuzz
   linters <- list(assignment_linter(), infix_spaces_linter())
   expected <- lapply(linters, \(l) list(linter = attr(l, "name")))
   expect_success(expect_lint("a=1", expected, linters, ignore_order = TRUE))

tests/testthat/test-expect_true_false_linter.R

@@ -3,7 +3,7 @@ test_that("expect_true_false_linter skips allowed usages", {
   # expect_true is a scalar test; testing logical vectors with expect_equal is OK
   expect_no_lint("expect_equal(x, c(TRUE, FALSE))", linter)
 
-  expect_no_lint("expect_equal(x, y, ignore_attr = TRUE)")
+  expect_no_lint("expect_equal(x, y, ignore_attr = TRUE)", linter)
 
   expect_no_lint("42 %>% expect_identical(42, ignore_attr = TRUE)", linter)
   expect_no_lint("42 %>% expect_identical(42, TRUE)", linter)

tests/testthat/test-function_left_parentheses_linter.R

@@ -7,7 +7,7 @@ test_that("function_left_parentheses_linter skips allowed usages", {
   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("blah <- function(blah) { }", linter) # nofuzz
   expect_no_lint("(1 + 1)", linter)
   expect_no_lint("( (1 + 1) )", linter)
   expect_no_lint("if (blah) { }", linter)
@@ -18,9 +18,9 @@ test_that("function_left_parentheses_linter skips allowed usages", {
   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("function(){function(){}}()()", linter) # nofuzz
+  expect_no_lint("c(function(){})[1]()", linter) # nofuzz
+  expect_no_lint("function(x) (mean(x) + 3)", linter) # nofuzz
   expect_no_lint('"blah (1)"', linter)
 })
 
@@ -197,7 +197,7 @@ test_that("newline in character string doesn't trigger false positive (#1963)",
   )
 })
 
-test_that("shorthand functions are handled", {
+test_that("shorthand functions are handled", { # nofuzz
   linter <- function_left_parentheses_linter()
   fun_lint_msg <- rex::rex("Remove spaces before the left parenthesis in a function definition.")
 

tests/testthat/test-indentation_linter.R

@@ -1,3 +1,4 @@
+# nofuzz start
 test_that("indentation linter flags unindented expressions", {
   linter <- indentation_linter(indent = 2L)
 
@@ -910,3 +911,4 @@ test_that("for loop gets correct linting", {
     linter
   )
 })
+# nofuzz end

tests/testthat/test-infix_spaces_linter.R

@@ -1,3 +1,4 @@
+# nofuzz start
 test_that("returns the correct linting", {
   ops <- c(
     "+",
@@ -234,3 +235,4 @@ test_that("lints vectorize", {
     infix_spaces_linter()
   )
 })
+# nofuzz end

tests/testthat/test-knitr_formats.R

@@ -120,7 +120,7 @@ test_that("it handles asciidoc", {
   )
 })
 
-test_that("it does _not_ handle brew", {
+test_that("it does _not_ handle brew", { # nofuzz
   expect_lint("'<% a %>'\n",
     checks = list(
       regexes[["quotes"]],
@@ -131,9 +131,8 @@ test_that("it does _not_ handle brew", {
 })
 
 test_that("it does _not_ error with inline \\Sexpr", {
-  expect_lint(
+  expect_no_lint(
     "#' text \\Sexpr{1 + 1} more text",
-    NULL,
     default_linters
   )
 })