Robust linters for comments in "natural" places

Author: MichaelChirico

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

@@ -38,9 +38,12 @@ sprintf_linter <- function() {
 
   pipes <- setdiff(magrittr_pipes, "%$%")
   in_pipe_xpath <- glue("self::expr[
-    preceding-sibling::*[1][self::PIPE or self::SPECIAL[{ xp_text_in_table(pipes) }]]
+    preceding-sibling::*[not(self::COMMENT)][1][
+      self::PIPE
+      or self::SPECIAL[{ xp_text_in_table(pipes) }
+    ]]
     and (
-      preceding-sibling::*[2]/STR_CONST
+      preceding-sibling::*[not(self::COMMENT)][2]/STR_CONST
       or SYMBOL_SUB[text() = 'fmt']/following-sibling::expr[1]/STR_CONST
     )
   ]")
@@ -89,7 +92,7 @@ sprintf_linter <- function() {
       arg_idx <- 2L:length(parsed_expr)
       parsed_expr[arg_idx + 1L] <- parsed_expr[arg_idx]
       names(parsed_expr)[arg_idx + 1L] <- arg_names[arg_idx]
-      parsed_expr[[2L]] <- xml2lang(xml_find_first(xml, "preceding-sibling::*[2]"))
+      parsed_expr[[2L]] <- xml2lang(xml_find_first(xml, "preceding-sibling::*[not(self::COMMENT)][2]"))
       names(parsed_expr)[2L] <- ""
     }
     parsed_expr <- zap_extra_args(parsed_expr)

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 = " | "
   )

R/unreachable_code_linter.R

@@ -76,33 +76,55 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 unreachable_code_linter <- function(allow_comment_regex = getOption("covr.exclude_end", "# nocov end")) {
+  # nolint next: object_usage_linter. Used in glue() in statically-difficult fashion to detect.
   expr_after_control <- "
     (//REPEAT | //ELSE | //FOR)/following-sibling::expr[1]
     | (//IF | //WHILE)/following-sibling::expr[2]
   "
+
+  unreachable_expr_cond_ws <- "
+  following-sibling::*[
+    not(self::OP-RIGHT-BRACE or self::OP-SEMICOLON or self::ELSE or preceding-sibling::ELSE)
+    and (not(self::COMMENT) or @line2 > preceding-sibling::*[not(self::COMMENT)][1]/@line2)
+  ][1]"
+  # when a semicolon is present, the condition is a bit different due to <exprlist> nodes
+  unreachable_expr_cond_sc <- "
+  parent::exprlist[OP-SEMICOLON]
+    /following-sibling::*[
+      not(self::OP-RIGHT-BRACE)
+      and (not(self::COMMENT) or @line1 > preceding-sibling::exprlist/expr/@line2)
+    ][1]
+  "
+
   # NB: use not(OP-DOLLAR) to prevent matching process$stop(), #1051
-  xpath_return_stop <- glue("
+  xpath_return_stop_fmt <- "
   (
     {expr_after_control}
-    | (//FUNCTION | //OP-LAMBDA)[following-sibling::expr[1]/*[1][self::OP-LEFT-BRACE]]/following-sibling::expr[1]
+    |
+    (//FUNCTION | //OP-LAMBDA)
+      /following-sibling::expr[OP-LEFT-BRACE][last()]
   )
-    /expr[expr[1][
+    //expr[expr[1][
       not(OP-DOLLAR or OP-AT)
       and SYMBOL_FUNCTION_CALL[text() = 'return' or text() = 'stop']
     ]]
-    /following-sibling::*[
-      not(self::OP-RIGHT-BRACE or self::OP-SEMICOLON)
-      and (not(self::COMMENT) or @line2 > preceding-sibling::*[1]/@line2)
-    ][1]
-  ")
-  xpath_next_break <- glue("
+    /{unreachable_expr_cond}
+  "
+  xpath_return_stop <- paste(
+    glue(xpath_return_stop_fmt, unreachable_expr_cond = unreachable_expr_cond_ws),
+    glue(xpath_return_stop_fmt, unreachable_expr_cond = unreachable_expr_cond_sc),
+    sep = " | "
+  )
+  xpath_next_break_fmt <- "
   ({expr_after_control})
-    /expr[NEXT or BREAK]
-    /following-sibling::*[
-      not(self::OP-RIGHT-BRACE or self::OP-SEMICOLON)
-      and (not(self::COMMENT) or @line2 > preceding-sibling::*[1]/@line2)
-    ][1]
-  ")
+    //expr[NEXT or BREAK]
+    /{unreachable_expr_cond}
+  "
+  xpath_next_break <- paste(
+    glue(xpath_next_break_fmt, unreachable_expr_cond = unreachable_expr_cond_ws),
+    glue(xpath_next_break_fmt, unreachable_expr_cond = unreachable_expr_cond_sc),
+    sep = " | "
+  )
 
   xpath_if_while <- "
     (//WHILE | //IF)[following-sibling::expr[1]/NUM_CONST[text() = 'FALSE']]

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()
+  )
+})