assignment_linter() gains operator= argument to allow, e.g. '=' assignments

NEWS.md

@@ -18,6 +18,7 @@
 * `scalar_in_linter` is now configurable to allow other `%in%` like operators to be linted. The data.table operator `%chin%` is no longer linted by default; use `in_operators = "%chin%"` to continue linting it. (@F-Noelle)
 * `lint()` and friends now normalize paths to forward slashes on Windows (@olivroy, #2613).
 * `undesirable_function_linter()`, `undesirable_operator_linter()`, and `list_comparison_linter()` were removed from the tag `efficiency` (@IndrajeetPatil, #2655). If you use `linters_with_tags("efficiency")` to include these linters, you'll need to adjust your config to keep linting your code against them. We did not find any such users on GitHub.
+* Arguments `allow_cascading_assign=`, `allow_right_assign=`, and `allow_pipe_assign=` to `assignment_linter()` are all deprecated in favor of the new `operator=` argument. Usage of a positional first argument like `assignment_linter(TRUE)`, of which we found 0 cases on GitHub, is totally deprecated to allow `operator=` to be positionally first. See below about the new argument.
 
 ## Bug fixes
 
@@ -61,6 +62,7 @@
 * `expect_no_lint()` was added as new function to cover the typical use case of expecting no lint message, akin to the recent {testthat} functions like `expect_no_warning()` (#2580, @F-Noelle).
 * `lint()` and friends emit a message if no lints are found (#2643, @IndrajeetPatil).
 * `{lintr}` now has a hex sticker (https://github.com/rstudio/hex-stickers/pull/110). Thank you, @gregswinehart!
+* `assignment_linter()` can be fully customized with the new `operator=` argument to specify an exact vector of assignment operators to allow (#2441, @MichaelChirico and @J-Moravec). The default is `<-` and `<<-`; authors wishing to use `=` (only) for assignment in their codebase can use `operator = "="`. This supersedes several old arguments: to accomplish `allow_cascading_assign=TRUE`, add `"<<-"` (and/or `"->>"`) to `operator=`; for `allow_right_assign=TRUE`, add `"->"` (and/or `"->>"`) to `operator=`; for `allow_pipe_assign=TRUE`, add `"%<>%"` to `operator=`. Use `operator = "any"` to denote "ignore all assignment operators"; in this case, only the value of `allow_trailing=` matters. Implicit assignments with `<-` are always ignored by `assignment_linter()`; use `implicit_assignment_linter()` to handle linting these.
 
 ### New linters
 

R/assignment_linter.R

@@ -1,12 +1,15 @@
 #' Assignment linter
 #'
-#' Check that `<-` is always used for assignment.
+#' Check that the specified operator is used for assignment.
 #'
-#' @param allow_cascading_assign Logical, default `TRUE`.
+#' @param operator Character vector of valid assignment operators. Defaults to allowing `<-` and `<<-`; other valid
+#'   options are `=`, `->`, `->>`, `%<>%`; use `"any"` to denote "allow all operators", in which case this linter only
+#'   considers `allow_trailing` for generating lints.
+#' @param allow_cascading_assign (Deprecated) Logical, default `TRUE`.
 #'   If `FALSE`, [`<<-`][base::assignOps] and `->>` are not allowed.
-#' @param allow_right_assign Logical, default `FALSE`. If `TRUE`, `->` and `->>` are allowed.
+#' @param allow_right_assign (Deprecated) Logical, default `FALSE`. If `TRUE`, `->` and `->>` are allowed.
 #' @param allow_trailing Logical, default `TRUE`. If `FALSE` then assignments aren't allowed at end of lines.
-#' @param allow_pipe_assign Logical, default `FALSE`. If `TRUE`, magrittr's `%<>%` assignment is allowed.
+#' @param allow_pipe_assign (Deprecated) Logical, default `FALSE`. If `TRUE`, magrittr's `%<>%` assignment is allowed.
 #'
 #' @examples
 #' # will produce lints
@@ -27,6 +30,11 @@
 #'   linters = assignment_linter()
 #' )
 #'
+#' lint(
+#'   text = "x <- 1",
+#'   linters = assignment_linter(operator = "=")
+#' )
+#'
 #' # okay
 #' lint(
 #'   text = "x <- mean(x)",
@@ -64,63 +72,122 @@
 #'   linters = assignment_linter(allow_pipe_assign = TRUE)
 #' )
 #'
+#' lint(
+#'   text = "x = 1",
+#'   linters = assignment_linter(operator = "=")
+#' )
+#'
 #' @evalRd rd_tags("assignment_linter")
 #' @seealso
 #' - [linters] for a complete list of linters available in lintr.
 #' - <https://style.tidyverse.org/syntax.html#assignment-1>
 #' - <https://style.tidyverse.org/pipes.html#assignment-2>
 #' @export
-assignment_linter <- function(allow_cascading_assign = TRUE,
+assignment_linter <- function(operator = c("<-", "<<-"),
+                              allow_cascading_assign = TRUE,
                               allow_right_assign = FALSE,
                               allow_trailing = TRUE,
                               allow_pipe_assign = FALSE) {
-  trailing_assign_xpath <- paste(
+  if (is.logical(operator)) {
+    cli_abort(c(
+      "'operator' should be a character vector but was logical.",
+      i = "If you intended positional usage of allow_cascading_assign=, that is hard-deprecated."
+    ))
+  }
+  if (!missing(allow_cascading_assign)) {
+    lintr_deprecated("allow_cascading_assign", '"<<-" and/or "->>" in operator', version = "3.2.0", type = "Argument")
+    operator <- drop_or_add(operator, "<<-", allow_cascading_assign)
+  }
+  if (!missing(allow_right_assign)) {
+    lintr_deprecated("allow_right_assign", '"->" in operator', version = "3.2.0", type = "Argument")
+    operator <- drop_or_add(operator, c("->", if (allow_cascading_assign) "->>"), allow_right_assign)
+  }
+  if (!missing(allow_pipe_assign)) {
+    lintr_deprecated("allow_pipe_assign", '"%<>%" in operator', version = "3.2.0", type = "Argument")
+    operator <- drop_or_add(operator, "%<>%", allow_pipe_assign)
+  }
+  all_operators <- c("<-", "=", "->", "<<-", "->>", "%<>%")
+  if ("any" %in% operator) {
+    operator <- all_operators
+  } else {
+    operator <- match.arg(operator, all_operators, several.ok = TRUE)
+  }
+  no_cascading <- !any(c("<<-", "->>") %in% operator)
+  trailing_assign_xpath <- paste0(
     collapse = " | ",
     c(
-      paste0("//LEFT_ASSIGN", if (allow_cascading_assign) "" else "[text() = '<-']"),
-      if (allow_right_assign) paste0("//RIGHT_ASSIGN", if (allow_cascading_assign) "" else "[text() = '->']"),
+      "//LEFT_ASSIGN",
+      "//RIGHT_ASSIGN",
+      "//EQ_ASSIGN",
       "//EQ_SUB",
       "//EQ_FORMALS",
-      if (!allow_pipe_assign) "//SPECIAL[text() = '%<>%']"
+      "//SPECIAL[text() = '%<>%']"
     ),
     "[@line1 < following-sibling::expr[1]/@line1]"
   )
 
-  xpath <- paste(collapse = " | ", c(
-    # always block = (NB: the parser differentiates EQ_ASSIGN, EQ_SUB, and EQ_FORMALS)
-    "//EQ_ASSIGN",
+  op_xpath_parts <- c(
+    if (!"=" %in% operator) "//EQ_ASSIGN",
     # -> and ->> are both 'RIGHT_ASSIGN'
-    if (!allow_right_assign) "//RIGHT_ASSIGN" else if (!allow_cascading_assign) "//RIGHT_ASSIGN[text() = '->>']",
+    glue("//RIGHT_ASSIGN[{ xp_text_in_table(setdiff(c('->', '->>'), operator)) }]"),
     # <-, :=, 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() = '<<-']",
-    if (!allow_trailing) trailing_assign_xpath,
-    if (!allow_pipe_assign) "//SPECIAL[text() = '%<>%']"
-  ))
+    glue("//LEFT_ASSIGN[{ xp_text_in_table(setdiff(c('<-', '<<-'), operator)) }]"),
+    if (!"%<>%" %in% operator) "//SPECIAL[text() = '%<>%']"
+  )
+  if (!is.null(op_xpath_parts)) {
+    # NB: Also used, essentially, in implicit_assignment_linter. Keep in sync.
+    implicit_assignment_xpath <- "
+      [not(parent::expr[
+        preceding-sibling::*[2][self::IF or self::WHILE]
+        or parent::forcond
+        or parent::expr/*[1][self::OP-LEFT-PAREN]
+      ])]
+    "
+    op_xpath <- paste0(op_xpath_parts, implicit_assignment_xpath, collapse = " | ")
+  } else {
+    op_xpath <- NULL
+  }
 
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
 
-    bad_expr <- xml_find_all(xml, xpath)
-    if (length(bad_expr) == 0L) {
-      return(list())
-    }
+    lints <- NULL
+    if (!is.null(op_xpath)) {
+      op_expr <- xml_find_all(xml, op_xpath)
 
-    operator <- xml_text(bad_expr)
-    lint_message_fmt <- rep("Use <-, not %s, for assignment.", length(operator))
-    lint_message_fmt[operator %in% c("<<-", "->>")] <-
-      "Replace %s by assigning to a specific environment (with assign() or <-) to avoid hard-to-predict behavior."
-    lint_message_fmt[operator == "%<>%"] <-
-      "Avoid the assignment pipe %s; prefer using <- and %%>%% separately."
+      op_text <- xml_text(op_expr)
+      op_lint_message_fmt <- rep(
+        sprintf(
+          "Use %s for assignment, not %%s.",
+          if (length(operator) > 1L) paste("one of", toString(operator)) else operator
+        ),
+        length(op_text)
+      )
+      if (no_cascading) {
+        op_lint_message_fmt[op_text %in% c("<<-", "->>")] <-
+          "Replace %s by assigning to a specific environment (with assign() or <-) to avoid hard-to-predict behavior."
+      }
+      op_lint_message_fmt[op_text == "%<>%"] <-
+        "Avoid the assignment pipe %s; prefer pipes and assignment in separate steps."
+
+      op_lint_message <- sprintf(op_lint_message_fmt, op_text)
+      lints <- xml_nodes_to_lints(op_expr, source_expression, op_lint_message, type = "style")
+    }
 
     if (!allow_trailing) {
-      bad_trailing_expr <- xml_find_all(xml, trailing_assign_xpath)
-      trailing_assignments <- xml2::xml_attrs(bad_expr) %in% xml2::xml_attrs(bad_trailing_expr)
-      lint_message_fmt[trailing_assignments] <- "Assignment %s should not be trailing at the end of a line."
+      trailing_assign_expr <- xml_find_all(xml, trailing_assign_xpath)
+      trailing_assign_text <- xml_text(trailing_assign_expr)
+      trailing_assign_msg_fmt <- "Assignment %s should not be trailing at the end of a line."
+      trailing_assign_msg <- sprintf(trailing_assign_msg_fmt, trailing_assign_text)
+      lints <- c(lints,
+        xml_nodes_to_lints(trailing_assign_expr, source_expression, trailing_assign_msg, type = "style")
+      )
     }
 
-    lint_message <- sprintf(lint_message_fmt, operator)
-    xml_nodes_to_lints(bad_expr, source_expression, lint_message, type = "style")
+    lints
   })
 }
+
+drop_or_add <- function(x, y, add) (if (add) union else setdiff)(x, y)

R/implicit_assignment_linter.R

@@ -79,6 +79,7 @@ implicit_assignment_linter <- function(except = c("bquote", "expression", "expr"
     sep = " | "
   )
 
+  # NB: Also used, essentially, in assignment_linter. Keep in sync.
   xpath <- glue("
     ({assignments})
       /parent::expr[

tests/testthat/test-exclusions.R

@@ -194,7 +194,7 @@ test_that("next-line exclusion works", {
       # NLN: line_length_linter.
       x = 1
     "),
-    rex::rex("Use <-, not =, for assignment."),
+    rex::rex("Use one of <-, <<- for assignment, not =."),
     list(linter, line_length_linter())
   )
 
@@ -204,7 +204,7 @@ test_that("next-line exclusion works", {
       x = 1 # NLN: assignment_linter.
       x = 2
     "),
-    list(rex::rex("Use <-, not =, for assignment."), line_number = 1L),
+    list(rex::rex("Use one of <-, <<- for assignment, not =."), line_number = 1L),
     linter
   )
 })

tests/testthat/test-expect_lint.R

@@ -3,7 +3,7 @@
 # for failure, always put the lint check or lint field that must fail first.
 
 linter <- assignment_linter()
-lint_msg <- "Use <-, not ="
+lint_msg <- "Use one of <-, <<- for assignment, not ="
 
 test_that("no checks", {
   expect_success(expect_no_lint("a", linter))

tests/testthat/test-knitr_extended_formats.R

@@ -4,7 +4,7 @@ test_that("marginfigure engine from tufte package doesn't cause problems", {
 
   expect_lint(
     file = test_path("knitr_extended_formats", "tufte.Rmd"),
-    checks = list(rex::rex("Use <-, not =, for assignment."), line_number = 11L),
+    checks = list(rex::rex("Use one of <-, <<- for assignment, not =."), line_number = 11L),
     default_linters,
     parse_settings = FALSE
   )
@@ -16,7 +16,7 @@ test_that("engines from bookdown package cause no problems", {
 
   expect_lint(
     file = test_path("knitr_extended_formats", "bookdown.Rmd"),
-    checks = list(rex::rex("Use <-, not =, for assignment."), line_number = 14L),
+    checks = list(rex::rex("Use one of <-, <<- for assignment, not =."), line_number = 14L),
     default_linters,
     parse_settings = FALSE
   )

tests/testthat/test-knitr_formats.R

@@ -1,5 +1,5 @@
 regexes <- list(
-  assign = rex::rex("Use <-, not =, for assignment."),
+  assign = rex::rex("Use one of <-, <<- for assignment, not =."),
   local_var = rex::rex("local variable"),
   quotes = rex::rex("Only use double-quotes."),
   trailing = rex::rex("Remove trailing blank lines."),