Robust linters for comments in "natural" places

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/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/outer_negation_linter.R

@@ -44,7 +44,7 @@ outer_negation_linter <- function() {
       not(expr[
         position() > 1
         and not(OP-EXCLAMATION)
-        and not(preceding-sibling::*[1][self::EQ_SUB])
+        and not(preceding-sibling::*[not(self::COMMENT)][1][self::EQ_SUB])
       ])
     ]
   "

R/shared_constants.R

@@ -220,7 +220,7 @@ object_name_xpath <- local({
   ]"
 
   # either an argument supplied positionally, i.e., not like 'arg = val', or the call <expr>
-  not_kwarg_cond <- "not(preceding-sibling::*[1][self::EQ_SUB])"
+  not_kwarg_cond <- "not(preceding-sibling::*[not(self::COMMENT)][1][self::EQ_SUB])"
 
   glue(xp_strip_comments("
   //SYMBOL[ {sprintf(xp_assignment_target_fmt, 'ancestor', '')} ]

R/unnecessary_concatenation_linter.R

@@ -66,7 +66,7 @@ unnecessary_concatenation_linter <- function(allow_single_expression = TRUE) { #
 
   pipes <- setdiff(magrittr_pipes, "%$%")
   to_pipe_xpath <- glue("
-    ./preceding-sibling::*[1][
+    ./preceding-sibling::*[not(self::COMMENT)][1][
       self::PIPE or
       self::SPECIAL[{ xp_text_in_table(pipes) }]
     ]

R/unnecessary_lambda_linter.R

@@ -125,10 +125,14 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) {
         .//expr[
           position() = 2
           and preceding-sibling::expr/SYMBOL_FUNCTION_CALL
-          and not(preceding-sibling::*[1][self::EQ_SUB])
+          and not(preceding-sibling::*[not(self::COMMENT)][1][self::EQ_SUB])
           and not(parent::expr[
             preceding-sibling::expr[not(SYMBOL_FUNCTION_CALL)]
-            or following-sibling::*[not(self::OP-RIGHT-PAREN or self::OP-RIGHT-BRACE)]
+            or following-sibling::*[not(
+              self::OP-RIGHT-PAREN
+              or self::OP-RIGHT-BRACE
+              or self::COMMENT
+            )]
           ])
         ]/SYMBOL
     ]
@@ -143,7 +147,12 @@ unnecessary_lambda_linter <- function(allow_comparison = FALSE) {
   purrr_fun_xpath <- glue("
   following-sibling::expr[
     OP-TILDE
-    and expr[OP-LEFT-PAREN/following-sibling::expr[1][not(preceding-sibling::*[2][self::SYMBOL_SUB])]/{purrr_symbol}]
+    and expr
+      /OP-LEFT-PAREN
+      /following-sibling::expr[1][
+        not(preceding-sibling::*[not(self::COMMENT)][2][self::SYMBOL_SUB])
+      ]
+      /{purrr_symbol}
     and not(expr/OP-LEFT-PAREN/following-sibling::expr[position() > 1]//{purrr_symbol})
   ]")
 

R/unnecessary_nesting_linter.R

@@ -234,7 +234,7 @@ unnecessary_nesting_linter <- function(
       # catch if (cond) { if (other_cond) { ... } }
       #   count(*): only OP-LEFT-BRACE, one <expr>, and OP-RIGHT-BRACE.
       #             Note that third node could be <expr_or_assign_or_help>.
-      "following-sibling::expr[OP-LEFT-BRACE and count(*) = 3]/expr[IF and not(ELSE)]"
+      "following-sibling::expr[OP-LEFT-BRACE and count(*) - count(COMMENT) = 3]/expr[IF and not(ELSE)]"
     ),
     collapse = " | "
   )

tests/testthat/test-conjunct_test_linter.R

@@ -1,21 +1,25 @@
 test_that("conjunct_test_linter skips allowed usages of expect_true", {
-  expect_lint("expect_true(x)", NULL, conjunct_test_linter())
-  expect_lint("testthat::expect_true(x, y, z)", NULL, conjunct_test_linter())
+  linter <- conjunct_test_linter()
+
+  expect_no_lint("expect_true(x)", linter)
+  expect_no_lint("testthat::expect_true(x, y, z)", linter)
 
   # more complicated expression
-  expect_lint("expect_true(x || (y && z))", NULL, conjunct_test_linter())
+  expect_no_lint("expect_true(x || (y && z))", linter)
   # the same by operator precedence, though not obvious a priori
-  expect_lint("expect_true(x || y && z)", NULL, conjunct_test_linter())
-  expect_lint("expect_true(x && y || z)", NULL, conjunct_test_linter())
+  expect_no_lint("expect_true(x || y && z)", linter)
+  expect_no_lint("expect_true(x && y || z)", linter)
 })
 
 test_that("conjunct_test_linter skips allowed usages of expect_true", {
-  expect_lint("expect_false(x)", NULL, conjunct_test_linter())
-  expect_lint("testthat::expect_false(x, y, z)", NULL, conjunct_test_linter())
+  linter <- conjunct_test_linter()
+
+  expect_no_lint("expect_false(x)", linter)
+  expect_no_lint("testthat::expect_false(x, y, z)", linter)
 
   # more complicated expression
   # (NB: xx && yy || zz and xx || yy && zz both parse with || first)
-  expect_lint("expect_false(x && (y || z))", NULL, conjunct_test_linter())
+  expect_no_lint("expect_false(x && (y || z))", linter)
 })
 
 test_that("conjunct_test_linter blocks && conditions with expect_true()", {
@@ -43,14 +47,14 @@ test_that("conjunct_test_linter blocks || conditions with expect_false()", {
 test_that("conjunct_test_linter skips allowed stopifnot() and assert_that() usages", {
   linter <- conjunct_test_linter()
 
-  expect_lint("stopifnot(x)", NULL, linter)
-  expect_lint("assert_that(x, y, z)", NULL, linter)
+  expect_no_lint("stopifnot(x)", linter)
+  expect_no_lint("assert_that(x, y, z)", linter)
 
   # more complicated expression
-  expect_lint("stopifnot(x || (y && z))", NULL, linter)
+  expect_no_lint("stopifnot(x || (y && z))", linter)
   # the same by operator precedence, though not obvious a priori
-  expect_lint("stopifnot(x || y && z)", NULL, linter)
-  expect_lint("assertthat::assert_that(x && y || z)", NULL, linter)
+  expect_no_lint("stopifnot(x || y && z)", linter)
+  expect_no_lint("assertthat::assert_that(x && y || z)", linter)
 })
 
 test_that("conjunct_test_linter blocks simple disallowed usages of stopifnot() and assert_that()", {
@@ -66,12 +70,23 @@ test_that("conjunct_test_linter blocks simple disallowed usages of stopifnot() a
 })
 
 test_that("conjunct_test_linter's allow_named_stopifnot argument works", {
+  linter <- conjunct_test_linter()
+
   # allowed by default
-  expect_lint(
+  expect_no_lint(
     "stopifnot('x must be a logical scalar' = length(x) == 1 && is.logical(x) && !is.na(x))",
-    NULL,
-    conjunct_test_linter()
+    linter
   )
+  # including with intervening comment
+  expect_no_lint(
+    trim_some("
+      stopifnot('x must be a logical scalar' = # comment
+        length(x) == 1 && is.logical(x) && !is.na(x)
+      )
+    "),
+    linter
+  )
+
   expect_lint(
     "stopifnot('x is a logical scalar' = length(x) == 1 && is.logical(x) && !is.na(x))",
     rex::rex("Write multiple conditions like stopifnot(A, B)"),
@@ -82,11 +97,11 @@ test_that("conjunct_test_linter's allow_named_stopifnot argument works", {
 test_that("conjunct_test_linter skips allowed usages", {
   linter <- conjunct_test_linter()
 
-  expect_lint("dplyr::filter(DF, A, B)", NULL, linter)
-  expect_lint("dplyr::filter(DF, !(A & B))", NULL, linter)
+  expect_no_lint("dplyr::filter(DF, A, B)", linter)
+  expect_no_lint("dplyr::filter(DF, !(A & B))", linter)
   # | is the "top-level" operator here
-  expect_lint("dplyr::filter(DF, A & B | C)", NULL, linter)
-  expect_lint("dplyr::filter(DF, A | B & C)", NULL, linter)
+  expect_no_lint("dplyr::filter(DF, A & B | C)", linter)
+  expect_no_lint("dplyr::filter(DF, A | B & C)", linter)
 })
 
 test_that("conjunct_test_linter blocks simple disallowed usages", {
@@ -105,22 +120,22 @@ test_that("conjunct_test_linter respects its allow_filter argument", {
   linter_dplyr <- conjunct_test_linter(allow_filter = "not_dplyr")
   lint_msg <- rex::rex("Use dplyr::filter(DF, A, B) instead of dplyr::filter(DF, A & B)")
 
-  expect_lint("dplyr::filter(DF, A & B)", NULL, linter_always)
-  expect_lint("dplyr::filter(DF, A & B & C)", NULL, linter_always)
-  expect_lint("DF %>% dplyr::filter(A & B)", NULL, linter_always)
+  expect_no_lint("dplyr::filter(DF, A & B)", linter_always)
+  expect_no_lint("dplyr::filter(DF, A & B & C)", linter_always)
+  expect_no_lint("DF %>% dplyr::filter(A & B)", linter_always)
   expect_lint("dplyr::filter(DF, A & B)", lint_msg, linter_dplyr)
   expect_lint("dplyr::filter(DF, A & B & C)", lint_msg, linter_dplyr)
   expect_lint("DF %>% dplyr::filter(A & B)", lint_msg, linter_dplyr)
-  expect_lint("filter(DF, A & B)", NULL, linter_dplyr)
-  expect_lint("filter(DF, A & B & C)", NULL, linter_dplyr)
-  expect_lint("DF %>% filter(A & B)", NULL, linter_dplyr)
+  expect_no_lint("filter(DF, A & B)", linter_dplyr)
+  expect_no_lint("filter(DF, A & B & C)", linter_dplyr)
+  expect_no_lint("DF %>% filter(A & B)", linter_dplyr)
 })
 
 test_that("filter() is assumed to be dplyr::filter() by default, unless o/w specified", {
   linter <- conjunct_test_linter()
 
-  expect_lint("stats::filter(A & B)", NULL, linter)
-  expect_lint("ns::filter(A & B)", NULL, linter)
+  expect_no_lint("stats::filter(A & B)", linter)
+  expect_no_lint("ns::filter(A & B)", linter)
   expect_lint(
     "DF %>% filter(A & B)",
     rex::rex("Use dplyr::filter(DF, A, B) instead of dplyr::filter(DF, A & B)"),

tests/testthat/test-fixed_regex_linter.R

@@ -352,13 +352,13 @@ test_that("'unescaped' regex can optionally be skipped", {
 })
 
 local({
+  linter <- fixed_regex_linter()
+  lint_msg <- "This regular expression is static"
   pipes <- pipes(exclude = c("%$%", "%T>%"))
+
   patrick::with_parameters_test_that(
     "linter is pipe-aware",
     {
-      linter <- fixed_regex_linter()
-      lint_msg <- "This regular expression is static"
-
       expect_lint(paste("x", pipe, "grepl(pattern = 'a')"), lint_msg, linter)
       expect_no_lint(paste("x", pipe, "grepl(pattern = '^a')"), linter)
       expect_no_lint(paste("x", pipe, "grepl(pattern = 'a', fixed = TRUE)"), linter)
@@ -377,3 +377,14 @@ local({
     .test_name = names(pipes)
   )
 })
+
+test_that("pipe-aware lint logic survives adversarial comments", {
+  expect_lint(
+    trim_some("
+      x %>%   grepl(pattern = # comment
+      'a')
+    "),
+    "This regular expression is static",
+    fixed_regex_linter()
+  )
+})

tests/testthat/test-object_length_linter.R

@@ -104,4 +104,14 @@ test_that("literals in assign() and setGeneric() are checked", {
   expect_lint("assign(x = 'badBadBadBadName', 2, env)", lint_msg, linter)
   expect_lint("assign(envir = 'good_env_name', 'badBadBadBadName', 2)", lint_msg, linter)
   expect_lint("assign(envir = 'good_env_name', x = 'badBadBadBadName', 2)", lint_msg, linter)
+
+  # adversarial comments
+  expect_lint(
+    trim_some("
+      assign(envir = # comment
+      'good_env_name', 'badBadBadBadName', 2)
+    "),
+    lint_msg,
+    linter
+  )
 })

tests/testthat/test-object_name_linter.R

@@ -345,6 +345,16 @@ test_that("literals in assign() and setGeneric() are checked", {
   expect_lint("assign(x = 'badName', 2, env)", lint_msg, linter)
   expect_lint("assign(envir = 'good_env_name', 'badName', 2)", lint_msg, linter)
   expect_lint("assign(envir = 'good_env_name', x = 'badName', 2)", lint_msg, linter)
+
+  # adversarial comments
+  expect_lint(
+    trim_some("
+      assign(envir = # comment
+      'good_env_name', 'badName', 2)
+    "),
+    lint_msg,
+    linter
+  )
 })
 
 test_that("generics assigned with '=' or <<- are registered", {

tests/testthat/test-outer_negation_linter.R

@@ -1,20 +1,20 @@
 test_that("outer_negation_linter skips allowed usages", {
   linter <- outer_negation_linter()
 
-  expect_lint("x <- any(y)", NULL, linter)
-  expect_lint("y <- all(z)", NULL, linter)
+  expect_no_lint("x <- any(y)", linter)
+  expect_no_lint("y <- all(z)", linter)
 
   # extended usage of any is not covered
-  expect_lint("any(!a & b)", NULL, linter)
-  expect_lint("all(a | !b)", NULL, linter)
-
-  expect_lint("any(a, b)", NULL, linter)
-  expect_lint("all(b, c)", NULL, linter)
-  expect_lint("any(!a, b)", NULL, linter)
-  expect_lint("all(a, !b)", NULL, linter)
-  expect_lint("any(a, !b, na.rm = TRUE)", NULL, linter)
+  expect_no_lint("any(!a & b)", linter)
+  expect_no_lint("all(a | !b)", linter)
+
+  expect_no_lint("any(a, b)", linter)
+  expect_no_lint("all(b, c)", linter)
+  expect_no_lint("any(!a, b)", linter)
+  expect_no_lint("all(a, !b)", linter)
+  expect_no_lint("any(a, !b, na.rm = TRUE)", linter)
   # ditto when na.rm is passed quoted
-  expect_lint("any(a, !b, 'na.rm' = TRUE)", NULL, linter)
+  expect_no_lint("any(a, !b, 'na.rm' = TRUE)", linter)
 })
 
 test_that("outer_negation_linter blocks simple disallowed usages", {
@@ -31,15 +31,25 @@ test_that("outer_negation_linter blocks simple disallowed usages", {
   # catch when all inputs are negated
   expect_lint("any(!x, !y)", not_all_msg, linter)
   expect_lint("all(!x, !y, na.rm = TRUE)", not_any_msg, linter)
+
+  # adversarial comment
+  expect_lint(
+    trim_some("
+      any(!x, na.rm = # comment
+      TRUE)
+    "),
+    not_all_msg,
+    linter
+  )
 })
 
 test_that("outer_negation_linter doesn't trigger on empty calls", {
   linter <- outer_negation_linter()
 
   # minimal version of issue
-  expect_lint("any()", NULL, linter)
+  expect_no_lint("any()", linter)
   # closer to what was is practically relevant, as another regression test
-  expect_lint("x %>% any()", NULL, linter)
+  expect_no_lint("x %>% any()", linter)
 })
 
 test_that("lints vectorize", {

tests/testthat/test-sprintf_linter.R

@@ -157,6 +157,26 @@ local({
   )
 })
 
+test_that("pipe logic survives adversarial comments", {
+  linter <- sprintf_linter()
+
+  expect_no_lint(
+    trim_some("
+      x |> # comment
+      sprintf(fmt = '%s')
+    "),
+    linter
+  )
+
+  expect_no_lint(
+    trim_some('
+      "%s" %>% # comment
+      sprintf("%s%s")
+    '),
+    linter
+  )
+})
+
 test_that("lints vectorize", {
   skip_if_not_r_version("4.1.0")