Improve the nofuzz system to allow specific exclusions

.dev/ast_fuzz_test.R

@@ -53,7 +53,7 @@ if (
 }
 
 contents[wrong_number_def_idx] <-
-  'wrong_number_fmt <- "got %d lints instead of %d%s\\nFile contents:\\n%s"'
+  '  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)
@@ -66,61 +66,81 @@ withr::defer({
 
 suppressMessages(pkgload::load_all())
 
+can_parse <- \(lines) !inherits(tryCatch(parse(text = lines), error = identity), "error")
+get_str <- \(x) tail(unlist(strsplit(x, ": ", fixed = TRUE)), 1L)
+
 # 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
 #   evaluated at run-time. So instead keep track of all edits in this object.
-# this approach to implementing 'nofuzz' feels painfully manual, but I couldn't
-#   figure out how else to get 'testthat' to give us what we need -- the failures
-#   object in the reporter is frustratingly inconsistent in whether the trace
-#   exists, and even if it does, we'd have to text-mangle to get the corresponding
-#   file names out. Also, the trace 'srcref' happens under keep.source=FALSE,
-#   so we lose any associated comments anyway. even that would not solve the issue
-#   of getting top-level exclusions done for 'nofuzz start|end' ranges, except
-#   maybe if it enabled us to reuse lintr's own exclude() system.
-# therefore we take this approach: pass over the test suite first and comment out
-#   any tests/units that have been marked 'nofuzz'. restore later. one consequence
-#   is there's no support for fuzzer-specific exclusion, e.g. we fully disable
-#   the unnecessary_placeholder_linter() tests because |> and _ placeholders differ.
+# these have to be enabled/disabled at runtime as it's not possible to disentagle which
+#   fuzzer caused the error ex-post (and it might be the interaction of >1 at issue).
+#   an earlier approach was like the current 'nofuzz' -- just comment out the troublesome
+#   tests from being run at all. But that led to a very quickly growing set of tests being
+#   skipped totally, which also hid some issues that are surfaced by the current approach.
+#   Another idea would be to just leave the enable/disable calls as code in the test suite,
+#   but I prefer the current approach of leaving them as comments: (1) it's more consistent
+#   with the 'nolint' exclusion system and (2) it doesn't distract the casual reader as much.
 test_restorations <- list()
 for (test_file in list.files("tests/testthat", pattern = "^test-", full.names = TRUE)) {
-  xml <- read_xml(xmlparsedata::xml_parse_data(parse(test_file, keep.source = TRUE)))
-  # parent::* to catch top-level comments (exprlist). matches one-line nofuzz and start/end ranges.
-  nofuzz_lines <- xml_find_all(xml, "//COMMENT[contains(text(), 'nofuzz')]/parent::*")
-  if (length(nofuzz_lines) == 0L) next
-
-  test_original <- test_lines <- readLines(test_file)
-
-  for (nofuzz_line in nofuzz_lines) {
-    comments <- xml_find_all(nofuzz_line, "COMMENT[contains(text(), 'nofuzz')]")
-    comment_text <- xml_text(comments)
-    # handle start/end ranges first.
-    start_idx <- grep("nofuzz start", comment_text, fixed = TRUE)
-    end_idx <- grep("nofuzz end", comment_text, fixed = TRUE)
-    if (length(start_idx) != length(end_idx) || any(end_idx < start_idx)) {
-      stop(sprintf(
-        "Mismatched '# nofuzz start' (%s), '# nofuzz end' (%s) in %s",
-        toString(start_idx), toString(end_idx), test_file
-      ))
+  test_lines <- readLines(test_file)
+  one_expr_idx <- grep("# nofuzz", test_lines, fixed = TRUE)
+  range_start_idx <- grep("^\\s*# fuzzer disable:", test_lines)
+  if (length(one_expr_idx) == 0L && length(range_start_idx) == 0L) next
+
+  test_original <- test_lines
+  pd <- getParseData(parse(test_file, keep.source = TRUE))
+
+  for (start_line in rev(one_expr_idx)) {
+    end_line <- start_line
+    while (end_line <= length(test_lines) && !can_parse(test_lines[start_line:end_line])) {
+      end_line <- end_line + 1L
     }
-
-    comment_ranges <- Map(`:`,
-      as.integer(xml_attr(comments[start_idx], "line1")),
-      as.integer(xml_attr(comments[end_idx], "line1"))
-    )
-    for (comment_range in comment_ranges) {
-      test_lines[comment_range] <- paste("#", test_lines[comment_range])
+    if (end_line > length(test_lines)) {
+      stop("Unable to parse any expression starting from line ", start_line)
+    }
+    comment_txt <- subset(pd, line1 == start_line & token == "COMMENT", select = "text", drop = TRUE)
+    # blanket disable means the test cannot be run. this happens e.g. for tests of encoding
+    #   that are too complicated to deal with in this GHA.
+    if (comment_txt == "# nofuzz") {
+      test_lines[start_line:end_line] <- ""
+    } else {
+      deactivated <- get_str(comment_txt)
+      test_lines <- c(
+        head(test_lines, start_line - 1L),
+        sprintf("deactivate_fuzzers('%s')", deactivated),
+        test_lines[start_line:end_line],
+        sprintf("activate_fuzzers('%s')", deactivated),
+        tail(test_lines, -end_line)
+      )
     }
+  }
 
-    if (length(start_idx) > 0L && !any(!start_idx & !end_idx)) next
+  if (length(one_expr_idx)) {
+    writeLines(test_lines, test_file)
+    pd <- getParseData(parse(test_file, keep.source = TRUE))
+    range_start_idx <- grep("^\\s*# fuzzer disable:", test_lines)
+  }
 
-    # NB: one-line tests line expect_lint(...) # nofuzz are not supported,
-    #   since the comment will attach to the parent test_that() & thus comment
-    #   out the whole unit. Easiest solution is just to spread out those few tests for now.
-    comment_range <- as.integer(xml_attr(nofuzz_line, "line1")):as.integer(xml_attr(nofuzz_line, "line2"))
-    test_lines[comment_range] <- paste("#", test_lines[comment_range])
+  range_end_idx <- grep("^\\s*# fuzzer enable:", test_lines)
+
+  if (length(range_start_idx) != length(range_end_idx) || any(range_end_idx < range_start_idx)) {
+    stop(sprintf(
+      "Mismatched '# fuzzer disable' (%s), '# fuzzer enable' (%s) in %s",
+      toString(range_start_idx), toString(range_end_idx), test_file
+    ))
+  }
+
+  for (ii in seq_along(range_start_idx)) {
+    start_line <- test_lines[range_start_idx[ii]]
+    test_lines[range_start_idx[ii]] <-
+      gsub("#.*", sprintf("deactivate_fuzzers('%s')", get_str(start_line)), start_line)
+    end_line <- test_lines[range_end_idx[ii]]
+    test_lines[range_end_idx[ii]] <-
+      gsub("#.*", sprintf("activate_fuzzers('%s')", get_str(end_line)), end_line)
   }
 
-  writeLines(test_lines, test_file)
+  if (length(range_start_idx)) writeLines(test_lines, test_file)
+
   test_restorations <- c(test_restorations, list(list(file = test_file, lines = test_original)))
 }
 withr::defer(for (restoration in test_restorations) writeLines(restoration$lines, restoration$file))
@@ -134,8 +154,7 @@ 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))
+print(table(`Summary of test statuses:` = 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
@@ -160,7 +179,7 @@ if (length(invalid_failures) > 0L) {
     \(x) sprintf("%s:%s", x$file, x$test),
     character(1L)
   )
-  cat("Some fuzzed tests failed unexpectedly!\n")
+  cat(sprintf("%d fuzzed tests failed unexpectedly!\n", length(invalid_failures)))
   print(invalid_failures)
-  stop("Use # nofuzz [start|end] to mark false positives or fix any bugs.")
+  stop("Fix any bugs, or use '# nofuzz'/'# fuzzer [dis|en]able' to mark false positives.")
 }

.dev/maybe_fuzz_content.R

@@ -9,13 +9,7 @@ maybe_fuzz_content <- function(file, lines) {
     file.copy(file, new_file, copy.mode = FALSE)
   }
 
-  apply_fuzzers(new_file, fuzzers = list(
-    function_lambda_fuzzer,
-    pipe_fuzzer,
-    dollar_at_fuzzer,
-    comment_injection_fuzzer,
-    assignment_fuzzer
-  ))
+  apply_fuzzers(new_file, fuzzers = .fuzzers$active)
 
   new_file
 }
@@ -106,19 +100,55 @@ apply_fuzzers <- function(f, fuzzers) {
     return(invisible())
   }
 
-  unedited <- lines <- readLines(f)
+  unedited <- lines <- readLines(f, warn = FALSE)
   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
+    if (is.null(updated_lines)) next # skip some I/O if we can
     writeLines(updated_lines, f)
-    # check if our attempted edit introduced some error; skip applying this fuzzer only if so
+    # check if our attempted edit introduced some error
     pd <- error_or_parse_data(f)
     if (inherits(pd, "error")) {
-      writeLines(lines, f)
-      next
+      writeLines(unedited, f)
+      return(invisible())
     }
     lines <- readLines(f)
   }
 
   invisible()
 }
+
+.fuzzers <- new.env()
+.fuzzers$active <- list(
+  assignment = assignment_fuzzer,
+  comment_injection = comment_injection_fuzzer,
+  dollar_at = dollar_at_fuzzer,
+  function_lambda = function_lambda_fuzzer,
+  pipe = pipe_fuzzer
+)
+.fuzzers$inactive <- list()
+
+deactivate_fuzzers <- function(names_str) {
+  req <- unlist(strsplit(names_str, " ", fixed = TRUE))
+  if (!all(req %in% names(.fuzzers$active))) {
+    stop(sprintf(
+      "Invalid attempt to deactivate fuzzers: '%s'\n  Currently active fuzzers: %s\n  Currently inactive fuzzers: %s",
+      names_str, toString(names(.fuzzers$active)), toString(names(.fuzzers$inactive))
+    ))
+  }
+  .fuzzers$inactive[req] <- .fuzzers$active[req]
+  .fuzzers$active[req] <- NULL
+  invisible()
+}
+
+activate_fuzzers <- function(names_str) {
+  req <- unlist(strsplit(names_str, " ", fixed = TRUE))
+  if (!all(req %in% names(.fuzzers$inactive))) {
+    stop(sprintf(
+      "Invalid attempt to activate fuzzers: '%s'\n  Currently active fuzzers: %s\n  Currently inactive fuzzers: %s",
+      names_str, toString(names(.fuzzers$active)), toString(names(.fuzzers$inactive))
+    ))
+  }
+  .fuzzers$active[req] <- .fuzzers$inactive[req]
+  .fuzzers$inactive[req] <- NULL
+  invisible()
+}

R/any_duplicated_linter.R

@@ -63,76 +63,78 @@ any_duplicated_linter <- function() {
   #  this lets us match on either side of EQ, where following-sibling
   #  assumes we are before EQ, preceding-sibling assumes we are after EQ.
   length_unique_xpath_parts <- glue("
-  //{ c('EQ', 'NE', 'GT', 'LT') }
-    /parent::expr
-    /expr[
-      expr[1]/SYMBOL_FUNCTION_CALL[text() = 'length']
-      and expr/expr[1][
-        SYMBOL_FUNCTION_CALL[text() = 'unique']
-        and (
-          following-sibling::expr =
-            parent::expr
-              /parent::expr
-              /parent::expr
-              /expr
-              /expr[1][SYMBOL_FUNCTION_CALL[text() = 'length']]
-              /following-sibling::expr
-          or following-sibling::expr[OP-DOLLAR or LBB]/expr[1] =
-            parent::expr
-              /parent::expr
-              /parent::expr
-              /expr
-              /expr[1][SYMBOL_FUNCTION_CALL[text() = 'nrow']]
-              /following-sibling::expr
-          or parent::expr
+  expr/expr[
+    expr[1]/SYMBOL_FUNCTION_CALL[text() = 'length']
+    and expr/expr[1][
+      SYMBOL_FUNCTION_CALL[text() = 'unique']
+      and (
+        following-sibling::expr =
+          parent::expr
             /parent::expr
             /parent::expr
-            /expr[
-              SYMBOL[text() = '.N']
-              or (expr/SYMBOL_FUNCTION_CALL[text() = 'n'] and count(expr) = 1)
-            ]
-        )
-      ]
+            /expr
+            /expr[1][SYMBOL_FUNCTION_CALL[text() = 'length']]
+            /following-sibling::expr
+        or following-sibling::expr[OP-DOLLAR or LBB]/expr[1] =
+          parent::expr
+            /parent::expr
+            /parent::expr
+            /expr
+            /expr[1][SYMBOL_FUNCTION_CALL[text() = 'nrow']]
+            /following-sibling::expr
+        or parent::expr
+          /parent::expr
+          /parent::expr
+          /expr[
+            SYMBOL[text() = '.N']
+            or (expr/SYMBOL_FUNCTION_CALL[text() = 'n'] and count(expr) = 1)
+          ]
+      )
     ]
+  ]
   ")
   length_unique_xpath <- paste(length_unique_xpath_parts, collapse = " | ")
 
   distinct_xpath <- glue("
-  //{ c('EQ', 'NE', 'GT', 'LT') }
-    /parent::expr
-    /expr[
-      expr[1][
-        SYMBOL_FUNCTION_CALL[text() = 'uniqueN' or text() = 'n_distinct']
-        and (
-          following-sibling::expr =
-            parent::expr
-              /parent::expr
-              /expr
-              /expr[1][SYMBOL_FUNCTION_CALL[text() = 'length' or text() = 'nrow']]
-              /following-sibling::expr
-          or following-sibling::expr[OP-DOLLAR or LBB]/expr[1] =
-            parent::expr
-              /parent::expr
-              /expr
-              /expr[1][SYMBOL_FUNCTION_CALL[text() = 'nrow']]
-              /following-sibling::expr
-          or parent::expr
+  expr/expr[
+    expr[1][
+      SYMBOL_FUNCTION_CALL[text() = 'uniqueN' or text() = 'n_distinct']
+      and (
+        following-sibling::expr =
+          parent::expr
             /parent::expr
-            /expr[
-              SYMBOL[text() = '.N']
-              or (expr/SYMBOL_FUNCTION_CALL[text() = 'n'] and count(expr) = 1)
-            ]
-        )
-      ]
+            /expr
+            /expr[1][SYMBOL_FUNCTION_CALL[text() = 'length' or text() = 'nrow']]
+            /following-sibling::expr
+        or following-sibling::expr[OP-DOLLAR or LBB]/expr[1] =
+          parent::expr
+            /parent::expr
+            /expr
+            /expr[1][SYMBOL_FUNCTION_CALL[text() = 'nrow']]
+            /following-sibling::expr
+        or parent::expr
+          /parent::expr
+          /expr[
+            SYMBOL[text() = '.N']
+            or (expr/SYMBOL_FUNCTION_CALL[text() = 'n'] and count(expr) = 1)
+          ]
+      )
     ]
+  ]
   ")
 
   uses_nrow_xpath <- "./parent::expr/expr/expr[1]/SYMBOL_FUNCTION_CALL[text() = 'nrow']"
   uses_dtn_xpath <- "./parent::expr/expr/SYMBOL[text() = '.N']"
   uses_dplyr_xpath <- "./parent::expr/expr/expr[1]/SYMBOL_FUNCTION_CALL[text() = 'n']"
 
   Linter(linter_level = "expression", function(source_expression) {
-    xml <- source_expression$xml_parsed_content
+    # NB: need two parents given three parent::expr in XPath and stripped comments.
+    xml <- source_expression$xml_parsed_content |>
+      xml_find_all("//EQ | //NE | //GT | //LT") |>
+      xml_parent() |>
+      xml_parent() |>
+      strip_comments_from_subtree()
+
     xml_calls <- source_expression$xml_find_function_calls("any")
 
     any_duplicated_expr <- xml_find_all(xml_calls, any_duplicated_xpath)

R/is_numeric_linter.R

@@ -42,15 +42,13 @@ is_numeric_linter <- function() {
 
   # testing things like is.numeric(x) || is.integer(x)
   or_xpath <- glue("
-  //OR2
-    /parent::expr[
-      expr/{is_numeric_expr}
-      and expr/{is_integer_expr}
-      and
-        expr/{is_numeric_expr}/following-sibling::expr[1]
-        = expr/{is_integer_expr}/following-sibling::expr[1]
-    ]
-  ")
+  self::*[
+    expr/{is_numeric_expr}
+    and expr/{is_integer_expr}
+    and
+      expr/{is_numeric_expr}/following-sibling::expr[1]
+      = expr/{is_integer_expr}/following-sibling::expr[1]
+  ]")
 
   # testing class(x) %in% c("numeric", "integer")
   class_xpath <- "
@@ -69,7 +67,11 @@ is_numeric_linter <- function() {
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
 
-    or_expr <- xml_find_all(xml, or_xpath)
+    or_expr <- xml |>
+      xml_find_all("//OR2") |>
+      xml_parent() |>
+      strip_comments_from_subtree() |>
+      xml_find_all(or_xpath)
     or_lints <- xml_nodes_to_lints(
       or_expr,
       source_expression = source_expression,