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
+    !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) {

NEWS.md

@@ -48,6 +48,38 @@
 * `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).
 * `sprintf_linter()` lints `sprintf()` and `gettextf()` calls when a constant string is passed to `fmt` (#2894, @Bisaloo).
+* 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
 
 ### New linters
 

R/brace_linter.R

@@ -134,7 +134,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/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/if_switch_linter.R

@@ -191,8 +191,6 @@
   # 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 @@
         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/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/object_usage_linter.R

@@ -61,13 +61,21 @@ object_usage_linter <- function(interpret_glue = NULL, interpret_extensions = c(
   # NB: the repeated expr[2][FUNCTION] XPath has no performance impact, so the different direct assignment XPaths are
   #   split for better readability, see PR#1197
   # TODO(#1106): use //[...] to capture assignments in more scopes
-  xpath_function_assignment <- "
-    expr[LEFT_ASSIGN or EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
-    | expr_or_assign_or_help[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
-    | equal_assign[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
-    | //SYMBOL_FUNCTION_CALL[text() = 'assign']/parent::expr/following-sibling::expr[2][FUNCTION or OP-LAMBDA]
-    | //SYMBOL_FUNCTION_CALL[text() = 'setMethod']/parent::expr/following-sibling::expr[3][FUNCTION or OP-LAMBDA]
-  "
+  fun_node <- "FUNCTION or OP-LAMBDA"
+  xpath_function_assignment <- glue("
+    expr[LEFT_ASSIGN or EQ_ASSIGN]/expr[2][{fun_node}]
+    | expr_or_assign_or_help[EQ_ASSIGN]/expr[2][{fun_node}]
+    | equal_assign[EQ_ASSIGN]/expr[2][{fun_node}]
+    | //SYMBOL_FUNCTION_CALL[text() = 'assign']/parent::expr/following-sibling::expr[2][{fun_node}]
+    | //SYMBOL_FUNCTION_CALL[text() = 'setMethod']/parent::expr/following-sibling::expr[3][{fun_node}]
+  ")
+
+  # code like:content
+  #   foo <- \ #comment
+  #     (x) x
+  # is technically valid, but won't parse unless the lambda is in a bigger expression (here '<-').
+  #   the same doesn't apply to 'function'.
+  xpath_unsafe_lambda <- "OP-LAMBDA[@line1 = following-sibling::*[1][self::COMMENT]/@line1]"
 
   # not all instances of linted symbols are potential sources for the observed violations -- see #1914
   symbol_exclude_cond <- "preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT or ancestor::expr[OP-TILDE]"
@@ -100,7 +108,9 @@ object_usage_linter <- function(interpret_glue = NULL, interpret_extensions = c(
     fun_assignments <- xml_find_all(xml, xpath_function_assignment)
 
     lapply(fun_assignments, function(fun_assignment) {
-      code <- get_content(lines = source_expression$content, fun_assignment)
+      # this will mess with the source line numbers. but I don't think anybody cares.
+      known_safe <- is.na(xml_find_first(fun_assignment, xpath_unsafe_lambda))
+      code <- get_content(lines = source_expression$content, fun_assignment, known_safe = known_safe)
       fun <- try_silently(eval(
         envir = env,
         parse(
@@ -190,8 +200,8 @@ get_assignment_symbols <- function(xml) {
       expr[RIGHT_ASSIGN]/expr[2]/SYMBOL[1] |
       equal_assign/expr[1]/SYMBOL[1] |
       expr_or_assign_or_help/expr[1]/SYMBOL[1] |
-      expr[expr[1][SYMBOL_FUNCTION_CALL/text()='assign']]/expr[2]/* |
-      expr[expr[1][SYMBOL_FUNCTION_CALL/text()='setMethod']]/expr[2]/*
+      expr[expr[1][SYMBOL_FUNCTION_CALL/text() = 'assign']]/expr[2]/* |
+      expr[expr[1][SYMBOL_FUNCTION_CALL/text() = 'setMethod']]/expr[2]/*
     "
   ))
 }

R/redundant_equals_linter.R

@@ -58,7 +58,7 @@ redundant_equals_linter <- function() {
     xml <- source_expression$xml_parsed_content
 
     bad_expr <- xml_find_all(xml, xpath)
-    op <- xml_text(xml_find_first(bad_expr, "*[2]"))
+    op <- xml_text(xml_find_first(bad_expr, "*[not(self::COMMENT)][2]"))
 
     xml_nodes_to_lints(
       bad_expr,

R/regex_subset_linter.R

@@ -47,25 +47,23 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 regex_subset_linter <- function() {
-  # parent::expr for LEFT_ASSIGN and RIGHT_ASSIGN, but, strangely,
-  #   parent::equal_assign for EQ_ASSIGN. So just use * as a catchall.
-  # See https://www.w3.org/TR/1999/REC-xpath-19991116/#booleans;
-  #   equality of nodes is based on the string value of the nodes, which
-  #   is basically what we need, i.e., whatever expression comes in
-  #   <expr>[grepl(pattern, <expr>)] matches exactly, e.g. names(x)[grepl(ptn, names(x))].
   xpath_fmt <- "
-  parent::expr[
-    parent::expr[
+  self::*[
+    not(LEFT_ASSIGN or EQ_ASSIGN or RIGHT_ASSIGN)
+  ]
+    /expr[
       OP-LEFT-BRACKET
-      and not(parent::*[LEFT_ASSIGN or EQ_ASSIGN or RIGHT_ASSIGN])
+      and expr[1] = expr/expr[position() = {arg_pos} ]
     ]
-    and expr[position() = {arg_pos} ] = parent::expr/expr[1]
-  ]"
+  "
   grep_xpath <- glue(xpath_fmt, arg_pos = 3L)
   stringr_xpath <- glue(xpath_fmt, arg_pos = 2L)
 
   Linter(linter_level = "expression", function(source_expression) {
-    grep_calls <- source_expression$xml_find_function_calls(c("grepl", "grep"))
+    grep_calls <- xml_parent(xml_parent(xml_parent(
+      source_expression$xml_find_function_calls(c("grepl", "grep"))
+    )))
+    grep_calls <- strip_comments_from_subtree(grep_calls)
     grep_expr <- xml_find_all(grep_calls, grep_xpath)
 
     grep_lints <- xml_nodes_to_lints(
@@ -78,7 +76,10 @@ regex_subset_linter <- function() {
       type = "warning"
     )
 
-    stringr_calls <- source_expression$xml_find_function_calls(c("str_detect", "str_which"))
+    stringr_calls <- xml_parent(xml_parent(xml_parent(
+      source_expression$xml_find_function_calls(c("str_detect", "str_which"))
+    )))
+    stringr_calls <- strip_comments_from_subtree(stringr_calls)
     stringr_expr <- xml_find_all(stringr_calls, stringr_xpath)
 
     stringr_lints <- xml_nodes_to_lints(

R/seq_linter.R

@@ -126,6 +126,7 @@ seq_linter <- function() {
       xml_find_all(seq_calls, seq_xpath),
       xml_find_all(xml, colon_xpath)
     )
+    seq_expr <- strip_comments_from_subtree(seq_expr)
 
     dot_expr1 <- get_fun(seq_expr, 1L)
     dot_expr2 <- get_fun(seq_expr, 2L)