Create condition_call_linter

DESCRIPTION

@@ -78,6 +78,7 @@ Collate:
     'comment_linters.R'
     'comments.R'
     'comparison_negation_linter.R'
+    'condition_call_linter.R'
     'condition_message_linter.R'
     'conjunct_test_linter.R'
     'consecutive_assertion_linter.R'

NAMESPACE

@@ -37,6 +37,7 @@ export(closed_curly_linter)
 export(commas_linter)
 export(commented_code_linter)
 export(comparison_negation_linter)
+export(condition_call_linter)
 export(condition_message_linter)
 export(conjunct_test_linter)
 export(consecutive_assertion_linter)

NEWS.md

@@ -34,6 +34,7 @@
 
 ### New linters
 
+* `condition_call_linter()` for ensuring consistent use of `call.` in `warning()` and `stop()`. The default `call. = FALSE` follows the tidyverse guidance of not displaying the call (#2226, @Bisaloo)
 * `sample_int_linter()` for encouraging `sample.int(n, ...)` over equivalents like `sample(1:n, ...)` (part of #884, @MichaelChirico).
 * `stopifnot_all_linter()` discourages tests with `all()` like `stopifnot(all(x > 0))`; `stopifnot()` runs `all()` itself, and uses a better error message (part of #884, @MichaelChirico).
 * `comparison_negation_linter()` for discouraging negated comparisons when a direct negation is preferable, e.g. `!(x == y)` could be `x != y` (part of #884, @MichaelChirico).

R/condition_call_linter.R

@@ -0,0 +1,116 @@
+#' Recommend usage of `call. = FALSE` in conditions
+#'
+#' This linter, with the default `display_call = FALSE`, enforces the
+#' recommendation of the tidyverse design guide regarding displaying error
+#' calls.
+#'
+#' @param display_call Logical specifying expected behaviour regarding `call.`
+#' argument in conditions.
+#'   - `NA` forces providing `call.=` but ignores its value (this can be used in
+#'     cases where you expect a mix of `call. = FALSE` and `call. = TRUE`)
+#'   - lints `call. = FALSE`
+#'   - forces `call. = FALSE` (lints `call. = TRUE` or missing `call.=` value)
+#'
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "stop('test')",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('test', call. = TRUE)",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('test', call. = FALSE)",
+#'   linters = condition_call_linter(display_call = TRUE)
+#' )
+#'
+#' lint(
+#'   text = "stop('this is a', 'test', call. = FALSE)",
+#'   linters = condition_call_linter(display_call = TRUE)
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "stop('test', call. = FALSE)",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('this is a', 'test', call. = FALSE)",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('test', call. = TRUE)",
+#'   linters = condition_call_linter(display_call = TRUE)
+#' )
+#'
+#' @evalRd rd_tags("condition_call_linter")
+#' @seealso
+#'   - [linters] for a complete list of linters available in lintr.
+#'   - <https://design.tidyverse.org/err-call.html>>
+#' @export
+condition_call_linter <- function(display_call = FALSE) {
+  call_xpath <- glue::glue("
+    following-sibling::SYMBOL_SUB[text() = 'call.']
+    /following-sibling::expr[1]
+    /NUM_CONST[text() = '{!display_call}']
+  ")
+  no_call_xpath <- "
+    parent::expr[
+      count(SYMBOL_SUB[text() = 'call.']) = 0
+    ]
+  "
+
+  if (is.na(display_call)) {
+    frag <- no_call_xpath
+  } else if (display_call) {
+    frag <- call_xpath
+  } else {
+    # call. = TRUE can be expressed in two way:
+    #  - either explicitly with call. = TRUE
+    #  - or by implicitly relying on the default
+    frag <- xp_or(call_xpath, no_call_xpath)
+  }
+
+  xpath <- glue::glue("
+    //SYMBOL_FUNCTION_CALL[text() = 'stop' or text() = 'warning']
+    /parent::expr[{frag}]
+    /parent::expr
+  ")
+
+  Linter(linter_level = "expression", function(source_expression) {
+
+    xml <- source_expression$xml_parsed_content
+    if (is.null(xml)) return(list())
+
+    bad_expr <- xml_find_all(xml, xpath)
+
+    if (is.na(display_call)) {
+      msg <- glue::glue(
+        "Provide an explicit value for call. in {xp_call_name(bad_expr)}()."
+      )
+    } else if (display_call) {
+      msg <- glue::glue(
+        "Use {xp_call_name(bad_expr)}(.) to display call in error message."
+      )
+    } else {
+      msg <- glue::glue(
+        "Use {xp_call_name(bad_expr)}(., call. = FALSE)",
+        " to not display call in error message."
+      )
+    }
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = msg,
+      type = "warning"
+    )
+  })
+}

R/linter_tag_docs.R

@@ -119,3 +119,13 @@ NULL
 #' @evalRd rd_linters("regex")
 #' @seealso [linters] for a complete list of linters available in lintr.
 NULL
+
+#' Tidyverse design linters
+#' @name tidy_design_linters
+#' @description
+#' Linters based on guidelines described in the 'Tidy design principles' book.
+#' @evalRd rd_linters("tidy_design")
+#' @seealso
+#'  - [linters] for a complete list of linters available in lintr.
+#'  - <https://design.tidyverse.org/>
+NULL

inst/lintr/linters.csv

@@ -11,6 +11,7 @@ closed_curly_linter,defunct
 commas_linter,style readability default configurable
 commented_code_linter,style readability best_practices default
 comparison_negation_linter,readability consistency
+condition_call_linter,style tidy_design best_practices configurable
 condition_message_linter,best_practices consistency
 conjunct_test_linter,package_development best_practices readability configurable pkg_testthat
 consecutive_assertion_linter,style readability consistency

tests/testthat/test-condition_call_linter.R

@@ -0,0 +1,39 @@
+test_that("condition_call_linter skips allowed usages", {
+  linter <- condition_call_linter()
+
+  expect_lint("stop('test', call. = FALSE)", NULL, linter)
+
+  # works even with multiple arguments
+  expect_lint("stop('this is a', 'test', call. = FALSE)", NULL, linter)
+
+  linter <- condition_call_linter(display_call = TRUE)
+
+  expect_lint("stop('test', call. = TRUE)", NULL, linter)
+
+  linter <- condition_call_linter(display_call = NA)
+
+  expect_lint("stop('test', call. = TRUE)", NULL, linter)
+  expect_lint("stop('test', call. = FALSE)", NULL, linter)
+})
+
+patrick::with_parameters_test_that(
+  "condition_call_linter blocks disallowed usages",
+  {
+    linter <- condition_call_linter()
+    lint_message <- rex::rex(call_name, anything, "to not display call")
+
+    expect_lint(paste0(call_name, "('test')"), lint_message, linter)
+    expect_lint(paste0(call_name, "('test', call. = TRUE)"), lint_message, linter)
+
+    linter <- condition_call_linter(display_call = TRUE)
+    lint_message <- rex::rex(call_name, anything, "to display call")
+
+    expect_lint(paste0(call_name, "('test', call. = FALSE)"), lint_message, linter)
+
+    linter <- condition_call_linter(display_call = NA)
+    lint_message <- rex::rex("explicit value", anything, call_name)
+
+    expect_lint(paste0(call_name, "('test')"), lint_message, linter)
+  },
+  call_name = c("stop", "warning")
+)