extend assignment_linter for other operators

NEWS.md

@@ -88,6 +88,7 @@ function calls. (#850, #851, @renkun-ken)
 * `lintr` now uses the 3rd edition of `testthat` (@MichaelChirico, #910)
 * `lintr` is adopting a new set of linters provided as part of Google's extension to the tidyverse style guide (#884, @michaelchirico)
    + `expect_null_linter()` Require usage of `expect_null(x)` over `expect_equal(x, NULL)` and similar
+* `assignment_linter()` now lints right assignment (`->` and `->>`) and gains two arguments. `allow_cascading_assign` (`TRUE` by default) toggles whether to lint `<<-` and `->>`; `allow_right_assign` toggles whether to lint `->` and `->>` (#915, @michaelchirico)
 
 # lintr 2.0.1
 

R/assignment_linter.R

@@ -2,23 +2,44 @@
 #'
 #' Check that `<-` is always used for assignment.
 #'
+#' @param allow_cascading_assign Logical, default `TRUE`.
+#'   If `FALSE`, [`<<-`][base::assignOps] and `->>` are not allowed.
+#' @param allow_right_assign Logical, default `FALSE`. If `TRUE`, `->` and `->>` are allowed.
 #' @evalRd rd_tags("assignment_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-assignment_linter <- function() {
+assignment_linter <- function(allow_cascading_assign = TRUE, allow_right_assign = FALSE) {
   Linter(function(source_file) {
-    lapply(
-      ids_with_token(source_file, "EQ_ASSIGN"),
-      function(id) {
-        parsed <- with_id(source_file, id)
-        Lint(
-          filename = source_file$filename,
-          line_number = parsed$line1,
-          column_number = parsed$col1,
-          type = "style",
-          message = "Use <-, not =, for assignment.",
-          line = source_file$lines[as.character(parsed$line1)]
-        )
-      })
+    if (is.null(source_file$xml_parsed_content)) return(list())
+
+    xml <- source_file$xml_parsed_content
+
+    # TODO: is there any performance consideration for //*[self::a or self::b] vs. //a|//b ?
+    xpath <- paste(collapse = " | ", c(
+      # always block = (NB: the parser differentiates EQ_ASSIGN, EQ_SUB, and EQ_FORMALS)
+      "//EQ_ASSIGN",
+      # -> and ->> are both 'RIGHT_ASSIGN'
+      if (!allow_right_assign) "//RIGHT_ASSIGN" else if (!allow_cascading_assign) "//RIGHT_ASSIGN[text() = '->>']",
+      # <-, :=, and <<- are all 'LEFT_ASSIGN'; check the text if blocking <<-.
+      # NB: := is not linted because of (1) its common usage in rlang/data.table and
+      #   (2) it's extremely uncommon as a normal assignment operator
+      if (!allow_cascading_assign) "//LEFT_ASSIGN[text() = '<<-']"
+    ))
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+    lapply(bad_expr, gen_assignment_lint, source_file)
   })
 }
+
+gen_assignment_lint <- function(expr, source_file) {
+  operator <- xml2::xml_text(expr)
+  if (operator %in% c("<<-", "->>")) {
+    message <- sprintf(
+      "%s can have hard-to-predict behavior; prefer assigning to a specific environment instead (with assign() or <-).",
+      operator
+    )
+  } else {
+    message <- sprintf("Use <-, not %s, for assignment.", operator)
+  }
+  xml_nodes_to_lint(expr, source_file, message, type = "style")
+}

tests/testthat/test-assignment_linter.R

@@ -1,6 +1,6 @@
 test_that("returns the correct linting", {
   linter <- assignment_linter()
-  msg <- rex("Use <-, not =, for assignment.")
+  msg <- rex::rex("Use <-, not =, for assignment.")
 
   expect_lint("blah", NULL, linter)
   expect_lint("blah <- 1", NULL, linter)
@@ -21,3 +21,26 @@ test_that("returns the correct linting", {
     linter
   )
 })
+
+test_that("arguments handle <<- and ->/->> correctly", {
+  expect_lint("1 -> blah", rex::rex("Use <-, not ->, for assignment."), assignment_linter())
+  expect_lint("1 ->> blah", rex::rex("->> can have hard-to-predict behavior;"), assignment_linter())
+
+  # <<- is only blocked optionally
+  expect_lint("1 <<- blah", NULL, assignment_linter())
+  expect_lint(
+    "1 <<- blah",
+    rex::rex("<<- can have hard-to-predict behavior;"),
+    assignment_linter(allow_cascading_assign = FALSE)
+  )
+
+  # blocking -> can be disabled
+  expect_lint("1 -> blah", NULL, assignment_linter(allow_right_assign = TRUE))
+  expect_lint("1 ->> blah", NULL, assignment_linter(allow_right_assign = TRUE))
+  # blocked under cascading assign but not under right assign --> blocked
+  expect_lint(
+    "1 ->> blah",
+    rex::rex("->> can have hard-to-predict behavior;"),
+    assignment_linter(allow_cascading_assign = FALSE, allow_right_assign = TRUE)
+  )
+})

tests/testthat/test-expect_lint.R

@@ -25,7 +25,7 @@ test_that("single check", {
 
   expect_error(expect_lint("a=1", c(message = msg, lineXXX = 1L), linter), "invalid field")
 
-  expect_failure(expect_lint("a=1", list(ranges = list(c(2L, 2L))), linter))
+  expect_failure(expect_lint("foo ()", list(ranges = list(c(2L, 2L))), function_left_parentheses_linter()))
   expect_success(expect_lint("\t1", list(ranges = list(c(1L, 1L))), no_tab_linter()))
   expect_success(expect_lint("a=1", list(message = msg, line_number = 1L), linter))
   expect_failure(expect_lint("a=1", list(2L, msg), linter))