unreachable_code_linter() lints on code in if (FALSE), while (FALSE)

NEWS.md

@@ -41,7 +41,9 @@
 * `function_argument_linter()` detects usage of `missing()` for the linted argument (#1546, @MichaelChirico). The simplest fix for `function_argument_linter()` lints is typically to set that argument to `NULL` by default, in which case it's usually preferable to update function logic checking `missing()` to check `is.null()` instead.
 * `equals_na_linter()` checks for `x %in% NA`, which is a more convoluted form of `is.na(x)` (#2088, @MichaelChirico).
 * `commas_linter()` gains an option `allow_trailing` (default `FALSE`) to allow trailing commas while indexing. (#2104, @MEO265)
-* `unreachable_code_linter()` finds unreachable code even in the presence of a comment or semicolon after `return()` or `stop()` (#2127, @MEO265).
+* `unreachable_code_linter()`
+  + finds unreachable code even in the presence of a comment or semicolon after `return()` or `stop()` (#2127, @MEO265).
+  + checks for code inside `if (FALSE)` and other conditional loops with deterministically false conditions (#1428, @ME0265).
 
 ### New linters
 

R/unreachable_code_linter.R

@@ -1,8 +1,9 @@
 #' Block unreachable code and comments following return statements
 #'
-#' Code after a top-level [return()] or [stop()] can't be reached; typically
-#'   this is vestigial code left after refactoring or sandboxing code, which is
-#'   fine for exploration, but shouldn't ultimately be checked in. Comments
+#' Code after a top-level [return()] or [stop()]
+#'   or in deterministically false conditional loops like `if (FALSE)` can't be reached;
+#'   typically this is vestigial code left after refactoring or sandboxing code, which
+#'   is fine for exploration, but shouldn't ultimately be checked in. Comments
 #'   meant for posterity should be placed *before* the final `return()`.
 #'
 #' @examples
@@ -14,6 +15,20 @@
 #'   linters = unreachable_code_linter()
 #' )
 #'
+#' code_lines <- "f <- if (FALSE) {\n 2 + 2\n}"
+#' writeLines(code_lines)
+#' lint(
+#'   text = code_lines,
+#'   linters = unreachable_code_linter()
+#' )
+#'
+#' code_lines <- "f <- while (FALSE) {\n 2 + 2\n}"
+#' writeLines(code_lines)
+#' lint(
+#'   text = code_lines,
+#'   linters = unreachable_code_linter()
+#' )
+#'
 #' # okay
 #' code_lines <- "f <- function() {\n  return(1 + 1)\n}"
 #' writeLines(code_lines)
@@ -22,12 +37,26 @@
 #'   linters = unreachable_code_linter()
 #' )
 #'
+#' code_lines <- "f <- if (foo) {\n 2 + 2\n}"
+#' writeLines(code_lines)
+#' lint(
+#'   text = code_lines,
+#'   linters = unreachable_code_linter()
+#' )
+#'
+#' code_lines <- "f <- while (foo) {\n 2 + 2\n}"
+#' writeLines(code_lines)
+#' lint(
+#'   text = code_lines,
+#'   linters = unreachable_code_linter()
+#' )
+#'
 #' @evalRd rd_tags("unreachable_code_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 unreachable_code_linter <- function() {
   # NB: use not(OP-DOLLAR) to prevent matching process$stop(), #1051
-  xpath <- "
+  xpath_return_stop <- "
   //FUNCTION
     /following-sibling::expr
     /expr[expr[1][not(OP-DOLLAR or OP-AT) and SYMBOL_FUNCTION_CALL[text() = 'return' or text() = 'stop']]]
@@ -36,6 +65,28 @@ unreachable_code_linter <- function() {
       and (not(self::COMMENT) or @line2 > preceding-sibling::*[1]/@line2)
     ][1]
   "
+  xpath_if_while <- "
+  (//WHILE | //IF)[following-sibling::expr[1]/NUM_CONST[text() = 'FALSE']]/following-sibling::expr[2]
+  "
+
+  xpath_else <- "
+  //IF[following-sibling::expr[1]/NUM_CONST[text() = 'TRUE']]
+    /following-sibling::ELSE/following-sibling::expr[1]
+  "
+
+  handle_inline_conditions <- function(expr) {
+    expr <- lapply(
+      expr,
+      function(x) {
+        if (xml_name(xml2::xml_child(x)) == "OP-LEFT-BRACE") {
+          xml_find_first(x, "expr")
+        } else {
+          x
+        }
+      }
+    )
+    expr[vapply(expr, xml2::xml_length, integer(1L)) != 0L]
+  }
 
   Linter(function(source_expression) {
     if (!is_lint_level(source_expression, "expression")) {
@@ -44,16 +95,37 @@ unreachable_code_linter <- function() {
 
     xml <- source_expression$xml_parsed_content
 
-    bad_expr <- xml_find_all(xml, xpath)
+    expr_return_stop <- xml_find_all(xml, xpath_return_stop)
 
-    is_nolint_end_comment <- xml2::xml_name(bad_expr) == "COMMENT" &
-      re_matches(xml_text(bad_expr), settings$exclude_end)
+    # exclude comments that start with a nolint directive
+    is_nolint_end_comment <- xml2::xml_name(expr_return_stop) == "COMMENT" &
+      re_matches(xml_text(expr_return_stop), settings$exclude_end)
 
-    xml_nodes_to_lints(
-      bad_expr[!is_nolint_end_comment],
+    lints_return_stop <- xml_nodes_to_lints(
+      expr_return_stop[!is_nolint_end_comment],
       source_expression = source_expression,
       lint_message = "Code and comments coming after a top-level return() or stop() should be removed.",
       type = "warning"
     )
+
+    expr_if_while <- handle_inline_conditions(xml_find_all(xml, xpath_if_while))
+
+    lints_if_while <- xml_nodes_to_lints(
+      expr_if_while,
+      source_expression = source_expression,
+      lint_message = "Code inside a conditional loop with a deterministically false condition should be removed.",
+      type = "warning"
+    )
+
+    expr_else <- handle_inline_conditions(xml_find_all(xml, xpath_else))
+
+    lints_else <- xml_nodes_to_lints(
+      expr_else,
+      source_expression = source_expression,
+      lint_message = "Code inside an else block after a deterministically true if condition should be removed.",
+      type = "warning"
+    )
+
+    c(lints_return_stop, lints_if_while, lints_else)
   })
 }

tests/testthat/test-unreachable_code_linter.R

@@ -197,6 +197,180 @@ test_that("unreachable_code_linter ignores terminal nolint end comments", {
   )
 })
 
+test_that("unreachable_code_linter identifies unreachable code in conditional loops", {
+  linter <- unreachable_code_linter()
+  msg <- rex::rex("Code inside a conditional loop with a deterministically false condition should be removed.")
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      if (FALSE) {
+        x <- 3
+      }
+      x + 3
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 3L, message = msg), linter)
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      if (FALSE) {
+        # Unlinted comment
+        x <- 3
+      }
+      x + 3
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 4L, message = msg), linter)
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      if (bla) {
+        x <- 3
+      } else if (FALSE) {
+        # Unlinted comment
+        y <- 3
+      }
+      x + 3
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 6L, message = msg), linter)
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      while (FALSE) {
+        x <- 3
+      }
+      x + 3
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 3L, message = msg), linter)
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      while (FALSE) {
+        # Unlinted comment
+        x <- 3
+      }
+      x + 3
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 4L, message = msg), linter)
+
+  lines <- "while (FALSE) x <- 3"
+
+  expect_lint(
+    lines,
+    list(line_number = 1L, ranges = list(c(15L, 20L)), message = msg),
+    linter
+  )
+
+  lines <- "if (FALSE) x <- 3 # Test comment"
+
+  expect_lint(
+    lines,
+    list(line_number = 1L, ranges = list(c(12L, 17L)), message = msg),
+    linter
+  )
+})
+
+test_that("unreachable_code_linter identifies unreachable code in conditional loops", {
+  linter <- unreachable_code_linter()
+  msg <- rex::rex("Code inside an else block after a deterministically true if condition should be removed.")
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      if (TRUE) {
+        x <- 3
+      } else {
+        # Unlinted comment
+        x + 3
+      }
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 6L, message = msg), linter)
+
+  lines <- trim_some("
+    foo <- function(bar) {
+      if (TRUE) {
+        x <- 3
+      } else if (bar) {
+        # Unlinted comment
+        x + 3
+      }
+    }
+  ")
+
+  expect_lint(lines, list(line_number = 4L, message = msg), linter)
+
+  lines <- "if (TRUE) x <- 3 else if (bar) x + 3"
+
+  expect_lint(
+    lines,
+    list(line_number = 1L, ranges = list(c(23L, 36L)), message = msg),
+    linter
+  )
+})
+
+test_that("unreachable_code_linter identifies unreachable code in mixed conditional loops", {
+  linter <- unreachable_code_linter()
+  msg <- rex::rex("Code inside a conditional loop with a deterministically false condition should be removed.")
+
+  lines <- trim_some("
+    function (bla) {
+      if (FALSE) {
+        code + 4
+      }
+      while (FALSE) {
+        code == 3
+      }
+      if (TRUE) {
+      } else {
+        code + bla
+      }
+      stop('.')
+      code <- 1
+    }
+  ")
+
+  expect_lint(
+    lines,
+    list(
+      list(line_number = 3L, message = msg),
+      list(line_number = 6L, message = msg),
+      list(
+        line_number = 10L,
+        message = rex::rex("Code inside an else block after a deterministically true if condition should be removed.")
+      ),
+      list(
+        line_number = 13L,
+        message = rex::rex("Code and comments coming after a top-level return() or stop()")
+      )
+    ),
+    linter
+  )
+
+  lines <- "if (FALSE) x <- 3 else if (TRUE) x + 3 else x + 4"
+
+  expect_lint(
+    lines,
+    list(
+      list(line_number = 1L, ranges = list(c(12L, 17L)), message = msg),
+      list(
+        line_number = 1L,
+        ranges = list(c(45L, 49L)),
+        message = rex::rex("Code inside an else block after a deterministically true if condition should be removed.")
+      )
+    ),
+    linter
+  )
+})
+
 # nolint start: commented_code_linter.
 # TODO(michaelchirico): extend to work on switch() statements
 # test_that("unreachable_code_linter interacts with switch() as expected", {