Implement implicit_assignment_linter()

Closes #1777

DESCRIPTION

@@ -104,6 +104,7 @@ Collate:
     'get_source_expressions.R'
     'ids_with_token.R'
     'ifelse_censor_linter.R'
+    'implicit_assignment_linter.R'
     'implicit_integer_linter.R'
     'indentation_linter.R'
     'infix_spaces_linter.R'

NAMESPACE

@@ -66,6 +66,7 @@ export(get_r_string)
 export(get_source_expressions)
 export(ids_with_token)
 export(ifelse_censor_linter)
+export(implicit_assignment_linter)
 export(implicit_integer_linter)
 export(indentation_linter)
 export(infix_spaces_linter)

NEWS.md

@@ -113,6 +113,8 @@
 * `unnecessary_nested_if_linter()` for checking unnecessary nested `if` statements where a single 
   `if` statement with appropriate conditional expression would suffice (@IndrajeetPatil and @AshesITR, #1778).
 
+* `implicit_assignment_linter()` for checking implicit assignments in function calls (@IndrajeetPatil and @AshesITR, #1777).
+
 ## Notes
 
 * `lint()` continues to support Rmarkdown documents. For users of custom .Rmd engines, e.g.

R/implicit_assignment_linter.R

@@ -0,0 +1,73 @@
+#' Avoid implicit assignment in function calls
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "if (x <- 1L) TRUE",
+#'   linters = implicit_assignment_linter()
+#' )
+#'
+#' lint(
+#'   text = "mean(x <- 1:4)",
+#'   linters = implicit_assignment_linter()
+#' )
+#'
+#' # okay
+#' writeLines("x <- 1L\nif (x) TRUE")
+#' lint(
+#'   text = "x <- 1L\nif (x) TRUE",
+#'   linters = implicit_assignment_linter()
+#' )
+#'
+#' writeLines("x <- 1:4\nmean(x)")
+#' lint(
+#'   text = "x <- 1:4\nmean(x)",
+#'   linters = implicit_assignment_linter()
+#' )
+#'
+#' @evalRd rd_tags("implicit_assignment_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+implicit_assignment_linter <- function() {
+  assignments <- c(
+    "LEFT_ASSIGN", # mean(x <- 1:4)
+    "RIGHT_ASSIGN" # mean(1:4 -> x)
+  )
+
+  controls <- c(
+    "//IF/following::expr/", # if (x <- 1L) { ... }
+    "//WHILE/following::expr/" # while (x <- 0L) { ... }
+  )
+  xpath_controls <- paste0(rep(controls, each = length(assignments)), assignments, collapse = " | ")
+
+  xpath_fun_call <- paste0(
+    "//SYMBOL_FUNCTION_CALL/parent::expr/following::expr[1]/",
+    assignments,
+    collapse = " | "
+  )
+
+  xpath <- paste0(c(xpath_controls, xpath_fun_call), collapse = " | ")
+
+  Linter(function(source_expression) {
+    # need the full file to also catch usages at the top level
+    if (!is_lint_level(source_expression, "file")) {
+      return(list())
+    }
+
+    xml <- source_expression$full_xml_parsed_content
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    lint_message <- paste(
+      "Avoid implicit assignments in function calls.",
+      "For example, instead of `if (x <- 1L) { ... }`, write `x <- 1L; if (x) { ... }`."
+    )
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = lint_message,
+      type = "warning"
+    )
+  })
+}

inst/lintr/linters.csv

@@ -34,6 +34,7 @@ function_argument_linter,style consistency best_practices
 function_left_parentheses_linter,style readability default
 function_return_linter,readability best_practices
 ifelse_censor_linter,best_practices efficiency
+implicit_assignment_linter,style best_practices readability
 implicit_integer_linter,style consistency best_practices configurable
 indentation_linter,style readability default configurable
 infix_spaces_linter,style readability default configurable

tests/testthat/test-implicit_assignment_linter.R

@@ -0,0 +1,65 @@
+test_that("implicit_assignment_linter skips allowed usages", {
+  linter <- implicit_assignment_linter()
+
+  expect_lint("x <- 1L", NULL, linter)
+  expect_lint("1L -> x", NULL, linter)
+
+  expect_lint("x <- mean(1:4)", NULL, linter)
+
+  expect_lint(
+    trim_some("
+    x <- 1:4
+    mean(x)"),
+    NULL,
+    linter
+  )
+
+
+  expect_lint(
+    trim_some("
+    x <- 1L
+    if (x) TRUE"),
+    NULL,
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+    0L -> abc
+    while (abc) {
+      FALSE
+    }"),
+    NULL,
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+    foo <- function(x) {
+    x <- x + 1
+      return(x)
+    }"),
+    NULL,
+    linter
+  )
+})
+
+test_that("implicit_assignment_linter blocks disallowed usages", {
+  lint_message <- rex::rex("Avoid implicit assignments in function calls.")
+  linter <- implicit_assignment_linter()
+
+  expect_lint("if (x <- 1L) TRUE", lint_message, linter)
+  expect_lint("if (1L -> x) TRUE", lint_message, linter)
+  expect_lint("while (x <- 0L) FALSE", lint_message, linter)
+  expect_lint("while (0L -> x) FALSE", lint_message, linter)
+
+  expect_lint("mean(x <- 1:4)", lint_message, linter)
+  expect_lint(
+    trim_some("
+    foo <- function(x) {
+      return(x <- x + 1)
+    }"),
+    lint_message,
+    linter
+  )
+})