Add a fourth 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
+    !all(endsWith(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)
@@ -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) {

NAMESPACE

@@ -192,4 +192,5 @@ importFrom(xml2,xml_find_first)
 importFrom(xml2,xml_find_lgl)
 importFrom(xml2,xml_find_num)
 importFrom(xml2,xml_name)
+importFrom(xml2,xml_parent)
 importFrom(xml2,xml_text)

NEWS.md

@@ -31,6 +31,38 @@
 * `object_usage_linter()` gains argument `interpret_extensions` to govern which false positive-prone common syntaxes should be checked for used objects (#1472, @MichaelChirico). Currently `"glue"` (renamed from earlier argument `interpret_glue`) and `"rlang"` are supported. The latter newly covers usage of the `.env` pronoun like `.env$key`, where `key` was previously missed as being a used variable.
 * `boolean_arithmetic_linter()` finds many more cases like `sum(x | y) == 0` where the total of a known-logical vector is compared to 0 (#1580, @MichaelChirico).
 * 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).
+* 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()`
+   + `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
+
 
 ### New linters
 

R/brace_linter.R

@@ -122,7 +122,7 @@ brace_linter <- function(allow_single_line = FALSE,
     { xp_cond_closed }
     and (
       (@line1 = preceding-sibling::*[1][not(self::OP-LEFT-BRACE)]/@line2)
-      or (@line1 = parent::expr/following-sibling::*[1][not(self::ELSE)]/@line1)
+      or (@line1 = parent::expr/following-sibling::*[not(self::COMMENT)][1][not(self::ELSE)]/@line1)
     )
   ]")
 

R/coalesce_linter.R

@@ -46,33 +46,33 @@
 coalesce_linter <- function() {
   braced_expr_cond <- "expr[1][OP-LEFT-BRACE and count(*) = 3]/expr"
   xpath <- glue("
-  parent::expr[
+  expr[expr[
     preceding-sibling::IF
     and (
       expr[2] = following-sibling::ELSE/following-sibling::expr
       or expr[2] = following-sibling::ELSE/following-sibling::{braced_expr_cond}
       or expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::ELSE/following-sibling::expr
       or expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::ELSE/following-sibling::{braced_expr_cond}
     )
-  ]
-    /parent::expr
+  ]]
   |
-  parent::expr[
-    preceding-sibling::OP-EXCLAMATION
-    and parent::expr/preceding-sibling::IF
+  self::*[expr[
+    preceding-sibling::IF
+    and OP-EXCLAMATION
     and (
-      expr[2] = parent::expr/following-sibling::expr[1]
-      or expr[2] = parent::expr/following-sibling::{braced_expr_cond}
-      or expr[2][LEFT_ASSIGN]/expr[1] = parent::expr/following-sibling::expr[1]
-      or expr[2][LEFT_ASSIGN]/expr[1] = parent::expr/following-sibling::{braced_expr_cond}
+      expr/expr[2] = following-sibling::expr[1]
+      or expr/expr[2] = following-sibling::{braced_expr_cond}
+      or expr/expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::expr[1]
+      or expr/expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::{braced_expr_cond}
     )
-  ]
-    /parent::expr
-    /parent::expr
+  ]]
   ")
 
   Linter(linter_level = "expression", function(source_expression) {
-    null_calls <- source_expression$xml_find_function_calls("is.null")
+    null_calls <- xml_parent(xml_parent(xml_parent(
+      source_expression$xml_find_function_calls("is.null")
+    )))
+    null_calls <- strip_comments_from_subtree(null_calls)
     bad_expr <- xml_find_all(null_calls, xpath)
     is_negation <- !is.na(xml_find_first(bad_expr, "expr/OP-EXCLAMATION"))
     observed <- ifelse(is_negation, "if (!is.null(x)) x else y", "if (is.null(x)) y else x")

R/comparison_negation_linter.R

@@ -65,13 +65,13 @@ comparison_negation_linter <- function() {
 
     bad_expr <- xml_find_all(xml, xpath)
 
-    comparator_node <- xml_find_first(bad_expr, "expr/expr/*[2]")
+    comparator_node <- xml_find_first(bad_expr, "expr/expr/*[not(self::COMMENT)][2]")
     comparator_name <- xml_name(comparator_node)
 
     # "typical" case is assumed to be !(x == y), so try that first, and back
     #   up to the less nested case. there may be a cleaner way to do this...
     unnested <- !comparator_name %in% names(comparator_inverses)
-    comparator_node[unnested] <- xml_find_first(bad_expr[unnested], "expr/*[2]")
+    comparator_node[unnested] <- xml_find_first(bad_expr[unnested], "expr/*[not(self::COMMENT)][2]")
     comparator_name[unnested] <- xml_name(comparator_node[unnested])
 
     comparator_text <- xml_text(comparator_node)

R/conjunct_test_linter.R

@@ -82,7 +82,8 @@ conjunct_test_linter <- function(allow_named_stopifnot = TRUE,
   following-sibling::expr[1][AND2]
     /parent::expr
   "
-  named_stopifnot_condition <- if (allow_named_stopifnot) "and not(preceding-sibling::*[1][self::EQ_SUB])" else ""
+  named_stopifnot_condition <-
+    if (allow_named_stopifnot) "and not(preceding-sibling::*[not(self::COMMENT)][1][self::EQ_SUB])" else ""
   stopifnot_xpath <- glue("
   following-sibling::expr[1][AND2 {named_stopifnot_condition}]
     /parent::expr

R/empty_assignment_linter.R

@@ -33,7 +33,7 @@
 empty_assignment_linter <- make_linter_from_xpath(
   # for some reason, the parent in the `=` case is <equal_assign>, not <expr>, hence parent::expr
   xpath = "
-  //OP-LEFT-BRACE[following-sibling::*[1][self::OP-RIGHT-BRACE]]
+  //OP-LEFT-BRACE[following-sibling::*[not(self::COMMENT)][1][self::OP-RIGHT-BRACE]]
     /parent::expr[
       preceding-sibling::LEFT_ASSIGN
       or preceding-sibling::EQ_ASSIGN

R/expect_comparison_linter.R

@@ -65,7 +65,7 @@ expect_comparison_linter <- function() {
     xml_calls <- source_expression$xml_find_function_calls("expect_true")
     bad_expr <- xml_find_all(xml_calls, xpath)
 
-    comparator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])")
+    comparator <- xml_find_chr(bad_expr, "string(expr[2]/*[not(self::COMMENT)][2])")
     expectation <- comparator_expectation_map[comparator]
     lint_message <- sprintf("%s(x, y) is better than expect_true(x %s y).", expectation, comparator)
     xml_nodes_to_lints(bad_expr, source_expression, lint_message = lint_message, type = "warning")

R/fixed_regex_linter.R

@@ -120,7 +120,7 @@ fixed_regex_linter <- function(allow_unescaped = FALSE) {
         and not({ in_pipe_cond })
       ) or (
         STR_CONST
-        and preceding-sibling::*[2][self::SYMBOL_SUB/text() = 'pattern']
+        and preceding-sibling::*[not(self::COMMENT)][2][self::SYMBOL_SUB/text() = 'pattern']
       )
     ]
   ")

R/if_switch_linter.R

@@ -191,8 +191,6 @@ if_switch_linter <- function(max_branch_lines = 0L, max_branch_expressions = 0L)
   # NB: IF AND {...} AND ELSE/... implies >= 3 equality conditions are present
   # .//expr/IF/...: the expr in `==` that's _not_ the STR_CONST
   # not(preceding::IF): prevent nested matches which might be incorrect globally
-  # not(. != .): don't match if there are _any_ expr which _don't_ match the top
-  #   expr
   if_xpath <- glue("
   //IF
     /parent::expr[
@@ -203,21 +201,28 @@ if_switch_linter <- function(max_branch_lines = 0L, max_branch_expressions = 0L)
         and {equal_str_cond}
         and ELSE/following-sibling::expr[IF and {equal_str_cond}]
       ]
-      and not(
-        .//expr/IF/following-sibling::{equal_str_cond}/expr[not(STR_CONST)]
-          != expr[1][EQ]/expr[not(STR_CONST)]
-      )
       and not({ max_lines_cond })
     ]
   ")
 
+  # not(. != .): don't match if there are _any_ expr which _don't_ match the top expr
+  #   do this as a second step to 
+  equality_test_cond <- glue("self::*[
+    .//expr/IF/following-sibling::{equal_str_cond}/expr[not(STR_CONST)]
+      != expr[1][EQ]/expr[not(STR_CONST)]
+  ]")
+
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
 
     bad_expr <- xml_find_all(xml, if_xpath)
+    expr_all_equal <- is.na(xml_find_first(
+      strip_comments_from_subtree(bad_expr),
+      equality_test_cond
+    ))
 
     lints <- xml_nodes_to_lints(
-      bad_expr,
+      bad_expr[expr_all_equal],
       source_expression = source_expression,
       lint_message = paste(
         "Prefer switch() statements over repeated if/else equality tests,",

R/ifelse_censor_linter.R

@@ -36,20 +36,19 @@
 #' @export
 ifelse_censor_linter <- function() {
   xpath <- glue("
-  following-sibling::expr[
+  self::*[expr[
     (LT or GT or LE or GE)
     and expr[1] = following-sibling::expr
     and expr[2] = following-sibling::expr
-  ]
-    /parent::expr
-  ")
+  ]]")
 
   Linter(linter_level = "expression", function(source_expression) {
-    ifelse_calls <- source_expression$xml_find_function_calls(ifelse_funs)
+    ifelse_calls <- xml_parent(source_expression$xml_find_function_calls(ifelse_funs))
+    ifelse_calls <- strip_comments_from_subtree(ifelse_calls)
     bad_expr <- xml_find_all(ifelse_calls, xpath)
 
     matched_call <- xp_call_name(bad_expr)
-    operator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])")
+    operator <- xml_find_chr(bad_expr, "string(expr[2]/*[not(self::COMMENT)][2])")
     match_first <- !is.na(xml_find_first(bad_expr, "expr[2][expr[1] = following-sibling::expr[1]]"))
     optimizer <- ifelse((operator %in% c("<", "<=")) == match_first, "pmin", "pmax")
     first_var <- rep_len("x", length(match_first))

R/implicit_assignment_linter.R

@@ -82,7 +82,7 @@ implicit_assignment_linter <- function(except = c("bquote", "expression", "expr"
   xpath <- glue("
     ({assignments})
       /parent::expr[
-        preceding-sibling::*[2][self::IF or self::WHILE]
+        preceding-sibling::*[not(self::COMMENT)][2][self::IF or self::WHILE]
         or parent::forcond
         or preceding-sibling::expr/{xpath_exceptions}
         or parent::expr/*[1][self::OP-LEFT-PAREN]
@@ -94,7 +94,7 @@ implicit_assignment_linter <- function(except = c("bquote", "expression", "expr"
   }
   if (allow_scoped) {
     # force 2nd preceding to ensure we're in the loop condition, not the loop expression
-    in_branch_cond <- "ancestor::expr[preceding-sibling::*[2][self::IF or self::WHILE]]"
+    in_branch_cond <- "ancestor::expr[preceding-sibling::*[not(self::COMMENT)][2][self::IF or self::WHILE]]"
     xpath <- paste0(
       xpath,
       # _if_ we're in an IF/WHILE branch, lint if the assigned SYMBOL appears anywhere later on.

R/length_test_linter.R

@@ -28,8 +28,13 @@ length_test_linter <- function() {
   Linter(linter_level = "expression", function(source_expression) {
     xml_calls <- source_expression$xml_find_function_calls("length")
     bad_expr <- xml_find_all(xml_calls, xpath)
+    bad_expr <- strip_comments_from_subtree(bad_expr)
 
-    expr_parts <- vapply(lapply(bad_expr, xml_find_all, "expr[2]/*"), xml_text, character(3L))
+    expr_parts <- vapply(
+      lapply(bad_expr, xml_find_all, "expr[2]/*[not(self::COMMENT)]"),
+      xml_text,
+      character(3L)
+    )
     lint_message <- sprintf(
       "Checking the length of a logical vector is likely a mistake. Did you mean `length(%s) %s %s`?",
       expr_parts[1L, ], expr_parts[2L, ], expr_parts[3L, ]

R/lintr-package.R

@@ -15,7 +15,8 @@
 #' @importFrom tools R_user_dir
 #' @importFrom utils capture.output getParseData  globalVariables head relist tail
 #' @importFrom xml2 as_list
-#'   xml_attr xml_children xml_find_all xml_find_chr xml_find_lgl xml_find_num xml_find_first xml_name xml_text
+#'   xml_attr xml_children xml_find_all xml_find_chr xml_find_lgl xml_find_num
+#'   xml_find_first xml_name xml_parent xml_text
 ## lintr namespace: end
 NULL
 

R/literal_coercion_linter.R

@@ -61,7 +61,7 @@ literal_coercion_linter <- function() {
     not(OP-DOLLAR or OP-AT)
     and (
       NUM_CONST[not(contains(translate(text(), 'E', 'e'), 'e'))]
-      or STR_CONST[not(following-sibling::*[1][self::EQ_SUB])]
+      or STR_CONST[not(following-sibling::*[not(self::COMMENT)][1][self::EQ_SUB])]
     )
   "
   xpath <- glue("
@@ -89,6 +89,7 @@ literal_coercion_linter <- function() {
       )
       # nocov end
     } else {
+      bad_expr <- strip_comments_from_subtree(bad_expr)
       # duplicate, unless we add 'rlang::' and it wasn't there originally
       coercion_str <- report_str <- xml_text(bad_expr)
       if (any(is_rlang_coercer) && !("package:rlang" %in% search())) {

R/matrix_apply_linter.R

@@ -97,6 +97,7 @@ matrix_apply_linter <- function() {
   Linter(linter_level = "expression", function(source_expression) {
     xml_calls <- source_expression$xml_find_function_calls("apply")
     bad_expr <- xml_find_all(xml_calls, xpath)
+    bad_expr <- strip_comments_from_subtree(bad_expr)
 
     variable <- xml_text(xml_find_all(bad_expr, variable_xpath))
 

R/nzchar_linter.R

@@ -112,8 +112,9 @@ nzchar_linter <- function() {
   #   its "opposite" (not inverse) if the bad usage is on the RHS,
   #   e.g. 0 < nchar(x) has to be treated as nchar(x) > 0.
   op_for_msg <- function(expr, const) {
-    op <- xml_name(xml_find_first(expr, "*[2]"))
-    maybe_needs_flip <- !is.na(xml_find_first(expr, sprintf("*[1][%s]", const)))
+    op <- xml_name(xml_find_first(expr, "*[not(self::COMMENT)][2]"))
+    maybe_needs_flip <-
+      !is.na(xml_find_first(expr, sprintf("*[not(self::COMMENT)][1][%s]", const)))
 
     ordered_ops <- c("GT", "GE", "LE", "LT")
     ordered_idx <- match(op, ordered_ops)