New function_return_linter()

DESCRIPTION

@@ -129,6 +129,7 @@ Collate:
     'redundant_equals_linter.R'
     'redundant_ifelse_linter.R'
     'regex_subset_linter.R'
+    'return_assignment_linter.R'
     'semicolon_linter.R'
     'seq_linter.R'
     'settings.R'

NAMESPACE

@@ -95,6 +95,7 @@ export(pipe_continuation_linter)
 export(redundant_equals_linter)
 export(redundant_ifelse_linter)
 export(regex_subset_linter)
+export(return_assignment_linter)
 export(sarif_output)
 export(semicolon_linter)
 export(semicolon_terminator_linter)

NEWS.md

@@ -26,6 +26,8 @@
 
 * `redundant_equals_linter()` for redundant comparisons to `TRUE` or `FALSE` like `is_treatment == TRUE` (#1500, @MichaelChirico)
 
+* `return_assignment_linter()` for assignments within the `return()` clause of a function, e.g. `return(x <- foo())` (@MichaelChirico)
+
 # lintr 3.0.1
 
 * Skip multi-byte tests in non UTF-8 locales (#1504)

R/return_assignment_linter.R

@@ -0,0 +1,32 @@
+#' Block assignments inside function returns
+#'
+#' `return(x <- ...)` is either distracting (because `x` is ignored), or
+#'   confusing (because assigning to `x` has some side effect that is muddled
+#'   by the dual-purpose expression).
+#'
+#' @evalRd rd_tags("return_assignment_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+return_assignment_linter <- function() {
+  xpath <- "
+  //SYMBOL_FUNCTION_CALL[text() = 'return']
+  /parent::expr/parent::expr/expr[LEFT_ASSIGN or RIGHT_ASSIGN]
+  "
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = "Move the assignment outside of the return() clause, or skip assignment altogether.",
+      type = "warning"
+    )
+  })
+}

inst/lintr/linters.csv

@@ -56,6 +56,7 @@ pipe_continuation_linter,style readability default
 redundant_equals_linter,best_practices readability efficiency common_mistakes
 redundant_ifelse_linter,best_practices efficiency consistency
 regex_subset_linter,best_practices efficiency
+return_assignment_linter,readability best_practices
 semicolon_linter,style readability default configurable
 semicolon_terminator_linter,style readability deprecated configurable
 seq_linter,robustness efficiency consistency best_practices default

tests/testthat/test-return_assignment_linter.R

@@ -0,0 +1,68 @@
+test_that("return_assignment_linter skips allowed usages", {
+  lines_simple <- trim_some("
+    foo <- function(x) {
+      x <- x + 1
+      return(x)
+    }
+  ")
+  expect_lint(lines_simple, NULL, return_assignment_linter())
+
+  # arguably an expression as complicated as this should also be assigned,
+  #   but for now that's out of the scope of this linter
+  lines_subassignment <- trim_some("
+    foo <- function(x) {
+      return(x[, {
+        col <- col + 1
+        .(grp, col)
+      }])
+    }
+  ")
+  expect_lint(lines_subassignment, NULL, return_assignment_linter())
+})
+
+test_that("return_assignment_linter blocks simple disallowed usages", {
+  linter <- return_assignment_linter()
+  lint_msg <- rex::rex("Move the assignment outside of the return() clause")
+
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        return(x <- x + 1)
+      }
+    "),
+    lint_msg,
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        return(x <<- x + 1)
+      }
+    "),
+    lint_msg,
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        return(x + 1 -> x)
+      }
+    "),
+    lint_msg,
+    linter
+  )
+
+  side_effect_lines <-
+  expect_lint(
+    trim_some("
+      e <- new.env()
+      foo <- function(x) {
+        return(e$val <- x + 1)
+      }
+    "),
+    lint_msg,
+    linter
+  )
+})