also skip slot extractions akin to dollar (#2039)

* also skip slot extractions akin to dollar

* extend to the full linter suite, add tests

* simpler XPath with parent:: axis

* revert edit for assignment, add regression tests

* new test for T on RHS of @

* new regression test

* news PR

Author: MichaelChirico

NEWS.md

@@ -8,6 +8,14 @@
 ## New and improved features
 
 * `library_call_linter()` can detect if all library calls are not at the top of your script (#2027, @nicholas-masel).
+* Several linters avoiding false positives in `$` extractions get the same exceptions for `@` extractions, e.g. `S4@T` will no longer throw a `T_and_F_symbol_linter()` hit (#2039, @MichaelChirico).
+  + `T_and_F_symbol_linter()`
+  + `for_loop_index_linter()`
+  + `literal_coercion_linter()`
+  + `object_name_linter()`
+  + `undesirable_function_linter()`
+  + `unreachable_code_linter()`
+  + `yoda_test_linter()`
 
 ## Changes to defaults
 

R/T_and_F_symbol_linter.R

@@ -31,29 +31,15 @@
 #' - <https://style.tidyverse.org/syntax.html#logical-vectors>
 #' @export
 T_and_F_symbol_linter <- function() { # nolint: object_name.
-  xpath <- paste0(
-    "//SYMBOL[",
-    "  (text() = 'T' or text() = 'F')", # T or F symbol
-    "  and not(preceding-sibling::OP-DOLLAR)", # not part of a $-subset expression
-    "  and not(parent::expr[",
-    "    following-sibling::LEFT_ASSIGN", # not target of left assignment
-    "    or preceding-sibling::RIGHT_ASSIGN", # not target of right assignment
-    "    or following-sibling::EQ_ASSIGN", # not target of equals assignment
-    "  ])",
-    "]"
-  )
+  symbol_xpath <- "//SYMBOL[
+    (text() = 'T' or text() = 'F')
+    and not(parent::expr[OP-DOLLAR or OP-AT])
+  ]"
+  assignment_xpath <-
+    "parent::expr[following-sibling::LEFT_ASSIGN or preceding-sibling::RIGHT_ASSIGN or following-sibling::EQ_ASSIGN]"
 
-  xpath_assignment <- paste0(
-    "//SYMBOL[",
-    "  (text() = 'T' or text() = 'F')", # T or F symbol
-    "  and not(preceding-sibling::OP-DOLLAR)", # not part of a $-subset expression
-    "  and parent::expr[", # , but ...
-    "    following-sibling::LEFT_ASSIGN", # target of left assignment
-    "    or preceding-sibling::RIGHT_ASSIGN", # target of right assignment
-    "    or following-sibling::EQ_ASSIGN", # target of equals assignment
-    "  ]",
-    "]"
-  )
+  usage_xpath <- sprintf("%s[not(%s)]", symbol_xpath, assignment_xpath)
+  assignment_xpath <- sprintf("%s[%s]", symbol_xpath, assignment_xpath)
 
   replacement_map <- c(T = "TRUE", F = "FALSE")
 
@@ -62,8 +48,8 @@ T_and_F_symbol_linter <- function() { # nolint: object_name.
       return(list())
     }
 
-    bad_exprs <- xml2::xml_find_all(source_expression$xml_parsed_content, xpath)
-    bad_assigns <- xml2::xml_find_all(source_expression$xml_parsed_content, xpath_assignment)
+    bad_usage <- xml2::xml_find_all(source_expression$xml_parsed_content, usage_xpath)
+    bad_assignment <- xml2::xml_find_all(source_expression$xml_parsed_content, assignment_xpath)
 
     make_lints <- function(expr, fmt) {
       symbol <- xml2::xml_text(expr)
@@ -79,8 +65,8 @@ T_and_F_symbol_linter <- function() { # nolint: object_name.
     }
 
     c(
-      make_lints(bad_exprs, "Use %s instead of the symbol %s."),
-      make_lints(bad_assigns, "Don't use %2$s as a variable name, as it can break code relying on %2$s being %1$s.")
+      make_lints(bad_usage, "Use %s instead of the symbol %s."),
+      make_lints(bad_assignment, "Don't use %2$s as a variable name, as it can break code relying on %2$s being %1$s.")
     )
   })
 }

R/for_loop_index_linter.R

@@ -34,10 +34,7 @@ for_loop_index_linter <- function() {
   //forcond
     /SYMBOL[text() =
       following-sibling::expr
-        //SYMBOL[not(
-          preceding-sibling::OP-DOLLAR
-          or parent::expr[preceding-sibling::OP-LEFT-BRACKET]
-        )]
+        //SYMBOL[not(parent::expr[OP-DOLLAR or OP-AT or preceding-sibling::OP-LEFT-BRACKET])]
         /text()
     ]
   "

R/literal_coercion_linter.R

@@ -54,11 +54,11 @@ literal_coercion_linter <- function() {
 
   # notes for clarification:
   #  - as.integer(1e6) is arguably easier to read than 1000000L
-  #  - in x$"abc", the "abc" STR_CONST is at the top level, so exclude OP-DOLLAR
+  #  - in x$"abc", the "abc" STR_CONST is at the top level, so exclude OP-DOLLAR (ditto OP-AT)
   #  - need condition against STR_CONST w/ EQ_SUB to skip quoted keyword arguments (see tests)
   #  - for {rlang} coercers, both `int(1)` and `int(1, )` need to be linted
   not_extraction_or_scientific <- "
-    not(OP-DOLLAR)
+    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])]

R/object_name_linter.R

@@ -10,7 +10,7 @@ object_name_xpath <- local({
   #   is not possible for strings, though we do still have to
   #   be aware of cases like 'a$"b" <- 1'.
   xp_assignment_target_fmt <- paste0(
-    "not(preceding-sibling::OP-DOLLAR)",
+    "not(parent::expr[OP-DOLLAR or OP-AT])",
     "and %1$s::expr[",
     " following-sibling::LEFT_ASSIGN",
     " or preceding-sibling::RIGHT_ASSIGN",

R/undesirable_function_linter.R

@@ -69,7 +69,7 @@ undesirable_function_linter <- function(fun = default_undesirable_functions,
       xp_text_in_table(c("library", "require")),
       "]])"
     ),
-    "not(preceding-sibling::OP-DOLLAR)"
+    "not(parent::expr[OP-DOLLAR or OP-AT])"
   )
 
   if (symbol_is_undesirable) {

R/unreachable_code_linter.R

@@ -37,7 +37,7 @@ unreachable_code_linter <- function() {
     /following-sibling::expr
     /*[
       self::expr
-      and expr[1][not(OP-DOLLAR) and SYMBOL_FUNCTION_CALL[text() = 'return' or text() = 'stop']]
+      and expr[1][not(OP-DOLLAR or OP-AT) and SYMBOL_FUNCTION_CALL[text() = 'return' or text() = 'stop']]
       and (position() != last() - 1 or not(following-sibling::OP-RIGHT-BRACE))
       and @line2 < following-sibling::*[1]/@line2
     ]

R/yoda_test_linter.R

@@ -42,7 +42,7 @@ yoda_test_linter <- function() {
   # TODO(#963): fully generalize this & re-use elsewhere
   const_condition <- "
     NUM_CONST
-    or (STR_CONST and not(OP-DOLLAR))
+    or (STR_CONST and not(OP-DOLLAR or OP-AT))
     or ((OP-PLUS or OP-MINUS) and count(expr[NUM_CONST]) = 2)
   "
   xpath <- glue::glue("

tests/testthat/test-T_and_F_symbol_linter.R

@@ -26,6 +26,10 @@ test_that("T_and_F_symbol_linter blocks disallowed usages", {
     linter
   )
 
+  expect_lint("DF$bool <- T", msg_true, linter)
+  expect_lint("S4@bool <- T", msg_true, linter)
+  expect_lint("sum(x, na.rm = T)", msg_true, linter)
+
   # Regression test for #657
   expect_lint(
     trim_some("
@@ -35,15 +39,16 @@ test_that("T_and_F_symbol_linter blocks disallowed usages", {
       )
 
       x$F <- 42L
+      y@T <- 84L
 
       T <- \"foo\"
       F = \"foo2\"
       \"foo3\" -> T
     "),
     list(
-      list(message = msg_variable_true),
-      list(message = msg_variable_false),
-      list(message = msg_variable_true)
+      list(message = msg_variable_true, line_number = 9L),
+      list(message = msg_variable_false, line_number = 10L),
+      list(message = msg_variable_true, line_number = 11L)
     ),
     linter
   )

tests/testthat/test-for_loop_index_linter.R

@@ -5,7 +5,22 @@ test_that("for_loop_index_linter skips allowed usages", {
 
   # this is OK, so not every symbol is problematic
   expect_lint("for (col in DF$col) {}", NULL, linter)
+  expect_lint("for (col in S4@col) {}", NULL, linter)
   expect_lint("for (col in DT[, col]) {}", NULL, linter)
+
+  # make sure symbol check is scoped
+  expect_lint(
+    trim_some("
+      {
+        for (i in 1:10) {
+          42L
+        }
+        i <- 7L
+      }
+    "),
+    NULL,
+    linter
+  )
 })
 
 test_that("for_loop_index_linter blocks simple disallowed usages", {

tests/testthat/test-literal_coercion_linter.R

@@ -3,6 +3,7 @@ test_that("literal_coercion_linter skips allowed usages", {
 
   # naive xpath includes the "_f0" here as a literal
   expect_lint('as.numeric(x$"_f0")', NULL, linter)
+  expect_lint('as.numeric(x@"_f0")', NULL, linter)
   # only examine the first method for as.<type> methods
   expect_lint("as.character(as.Date(x), '%Y%m%d')", NULL, linter)
 

tests/testthat/test-object_name_linter.R

@@ -105,14 +105,29 @@ test_that("linter accepts vector of styles", {
 test_that("dollar subsetting only lints the first expression", {
   # Regression test for #582
   linter <- object_name_linter()
-  lint_msg <- "Variable and function name style should match snake_case or symbols."
+  lint_msg <- rex::rex("Variable and function name style should match snake_case or symbols.")
 
   expect_lint("my_var$MY_COL <- 42L", NULL, linter)
   expect_lint("MY_VAR$MY_COL <- 42L", lint_msg, linter)
-  expect_lint("my_var$MY_SUB$MY_COL <- 42L", NULL, linter)
-  expect_lint("MY_VAR$MY_SUB$MY_COL <- 42L", lint_msg, linter)
+  expect_lint("my_var@MY_SUB <- 42L", NULL, linter)
+  expect_lint("MY_VAR@MY_SUB <- 42L", lint_msg, linter)
 })
 
+patrick::with_parameters_test_that(
+  "nested extraction only lints on the first symbol",
+  expect_lint(
+    sprintf("%s%sMY_SUB%sMY_COL <- 42L", if (should_lint) "MY_VAR" else "my_var", op1, op2),
+    if (should_lint) rex::rex("Variable and function name style should match snake_case or symbols."),
+    object_name_linter()
+  ),
+  .cases = within(
+    expand.grid(should_lint = c(TRUE, FALSE), op1 = c("$", "@"), op2 = c("$", "@"), stringsAsFactors = FALSE),
+    {
+      .test_name <- sprintf("(should lint? %s, op1=%s, op2=%s)", should_lint, op1, op2)
+    }
+  )
+)
+
 test_that("assignment targets of compound lhs are correctly identified", {
   linter <- object_name_linter()
   lint_msg <- "Variable and function name style should match snake_case or symbols."

tests/testthat/test-undesirable_function_linter.R

@@ -22,6 +22,7 @@ test_that("linter returns correct linting", {
   )
   # regression test for #1050
   expect_lint("df$return <- 1", NULL, linter)
+  expect_lint("df@return <- 1", NULL, linter)
 })
 
 test_that("it's possible to NOT lint symbols", {

tests/testthat/test-unreachable_code_linter.R

@@ -119,6 +119,17 @@ test_that("unreachable_code_linter ignores code after foo$stop(), which might be
     NULL,
     unreachable_code_linter()
   )
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        bar <- get_process()
+        bar@stop()
+        TRUE
+      }
+    "),
+    NULL,
+    unreachable_code_linter()
+  )
 })
 
 test_that("unreachable_code_linter ignores terminal nolint end comments", {

tests/testthat/test-yoda_test_linter.R

@@ -34,6 +34,7 @@ test_that("yoda_test_linter blocks simple disallowed usages", {
 test_that("yoda_test_linter ignores strings in $ expressions", {
   # the "key" here shows up at the same level of the parse tree as plain "key" normally would
   expect_lint('expect_equal(x$"key", 2)', NULL, yoda_test_linter())
+  expect_lint('expect_equal(x@"key", 2)', NULL, yoda_test_linter())
 })
 
 # if we only inspect the first argument & ignore context, get false positives