New consecutive_suppression_linter (#2306)

* New consecutive_suppression_linter

* preparing for a git merge collision :(

* salvaged, maybe?

* finish first pass at merge of R file

* first pass at merge of tests

* refactor NEWS

* re-document

* vestige in linter db

* missing ','

* rename

* example linting all rules

* intermingling test

NEWS.md

@@ -18,7 +18,9 @@
 ## New and improved features
 
 * More helpful errors for invalid configs (#2253, @MichaelChirico).
-* `library_call_linter()` is extended to encourage all packages to be attached with `library(symbol)`, not `library("symbol", character.only = TRUE)` or "vectorized" approaches looping over package names (part of #884, @MichaelChirico).
+* `library_call_linter()` is extended
+  + to encourage all packages to be attached with `library(symbol)`, not `library("symbol", character.only = TRUE)` or "vectorized" approaches looping over package names (part of #884, @MichaelChirico).
+  + to discourage many consecutive calls to `suppressMessages()` or `suppressPackageStartupMessages()` (part of #884, @MichaelChirico).
 
 ### New linters
 

R/library_call_linter.R

@@ -5,6 +5,9 @@
 #'  - Enforce such calls to all be at the top of the script.
 #'  - Block usage of argument `character.only`, in particular
 #'    for loading packages in a loop.
+#'  - Block consecutive calls to `suppressMessages(library(.))`
+#'    in favor of using [suppressMessages()] only once to suppress
+#'    messages from all `library()` calls. Ditto [suppressPackageStartupMessages()].
 #'
 #' @param allow_preamble Logical, default `TRUE`. If `FALSE`,
 #'   no code is allowed to precede the first `library()` call,
@@ -36,6 +39,13 @@
 #'   linters = library_call_linter()
 #' )
 #'
+#' code <- "suppressMessages(library(dplyr))\nsuppressMessages(library(tidyr))"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = library_call_linter()
+#' )
+#'
 #' # okay
 #' code <- "library(dplyr)\nprint('test')"
 #' writeLines(code)
@@ -62,30 +72,40 @@
 #'   linters = library_call_linter()
 #' )
 #'
+#' code <- "suppressMessages({\n  library(dplyr)\n  library(tidyr)\n})"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = library_call_linter()
+#' )
+#'
 #' @evalRd rd_tags("library_call_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 library_call_linter <- function(allow_preamble = TRUE) {
-  attach_call <- "text() = 'library' or text() = 'require'"
-  unsuppressed_call <- glue("not( {attach_call} or starts-with(text(), 'suppress'))")
+  attach_calls <- c("library", "require")
+  attach_call_cond <- xp_text_in_table(attach_calls)
+  suppress_call_cond <- xp_text_in_table(c("suppressMessages", "suppressPackageStartupMessages"))
+
+  unsuppressed_call_cond <- glue("not( {xp_or(attach_call_cond, suppress_call_cond)} )")
   if (allow_preamble) {
-    unsuppressed_call <- xp_and(
-      unsuppressed_call,
-      glue("@line1 > //SYMBOL_FUNCTION_CALL[{ attach_call }][1]/@line1")
+    unsuppressed_call_cond <- xp_and(
+      unsuppressed_call_cond,
+      glue("@line1 > //SYMBOL_FUNCTION_CALL[{ attach_call_cond }][1]/@line1")
     )
   }
   upfront_call_xpath <- glue("
-    //SYMBOL_FUNCTION_CALL[{ attach_call }][last()]
+    //SYMBOL_FUNCTION_CALL[{ attach_call_cond }][last()]
       /preceding::expr
-      /SYMBOL_FUNCTION_CALL[{ unsuppressed_call }][last()]
-      /following::expr[SYMBOL_FUNCTION_CALL[{ attach_call }]]
+      /SYMBOL_FUNCTION_CALL[{ unsuppressed_call_cond }][last()]
+      /following::expr[SYMBOL_FUNCTION_CALL[{ attach_call_cond }]]
       /parent::expr
   ")
 
   # STR_CONST: block library|require("..."), i.e., supplying a string literal
   # ancestor::expr[FUNCTION]: Skip usages inside functions a la {knitr}
-  char_only_direct_xpath <- "
-  //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require']
+  char_only_direct_xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[{attach_call_cond}]
     /parent::expr
     /parent::expr[
       expr[2][STR_CONST]
@@ -94,13 +114,13 @@ library_call_linter <- function(allow_preamble = TRUE) {
         and not(ancestor::expr[FUNCTION])
       )
     ]
-  "
+  ")
 
   bad_indirect_funs <- c("do.call", "lapply", "sapply", "map", "walk")
-  call_symbol_cond <- "
-  SYMBOL[text() = 'library' or text() = 'require']
-    or STR_CONST[text() = '\"library\"' or text() = '\"require\"']
-  "
+  call_symbol_cond <- glue("
+    SYMBOL[{attach_call_cond}]
+    or STR_CONST[{ xp_text_in_table(dQuote(attach_calls, '\"')) }]
+  ")
   char_only_indirect_xpath <- glue("
   //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(bad_indirect_funs) }]
     /parent::expr
@@ -111,6 +131,23 @@ library_call_linter <- function(allow_preamble = TRUE) {
   ")
   call_symbol_path <- glue("./expr[{call_symbol_cond}]")
 
+  attach_expr_cond <- glue("expr[expr[SYMBOL_FUNCTION_CALL[{attach_call_cond}]]]")
+
+  # Use `calls` in the first condition, not in the second, to prevent, e.g.,
+  #   the first call matching calls[1] but the second matching calls[2].
+  #   That is, ensure that calls[i] only matches a following call to calls[i].
+  # match on the expr, not the SYMBOL_FUNCTION_CALL, to ensure
+  #   namespace-qualified calls only match if the namespaces do.
+  consecutive_suppress_xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[{ suppress_call_cond }]
+    /parent::expr
+    /parent::expr[
+      expr[SYMBOL_FUNCTION_CALL[{ suppress_call_cond }]] =
+        following-sibling::expr[1][{attach_expr_cond}]/expr
+      and {attach_expr_cond}
+    ]
+  ")
+
   Linter(function(source_expression) {
     if (!is_lint_level(source_expression, "file")) {
       return(list())
@@ -120,12 +157,12 @@ library_call_linter <- function(allow_preamble = TRUE) {
 
     upfront_call_expr <- xml_find_all(xml, upfront_call_xpath)
 
-    call_name <- xp_call_name(upfront_call_expr)
+    upfront_call_name <- xp_call_name(upfront_call_expr)
 
     upfront_call_lints <- xml_nodes_to_lints(
       upfront_call_expr,
       source_expression = source_expression,
-      lint_message = sprintf("Move all %s calls to the top of the script.", call_name),
+      lint_message = sprintf("Move all %s calls to the top of the script.", upfront_call_name),
       type = "warning"
     )
 
@@ -161,6 +198,20 @@ library_call_linter <- function(allow_preamble = TRUE) {
       type = "warning"
     )
 
-    c(upfront_call_lints, char_only_direct_lints, char_only_indirect_lints)
+    consecutive_suppress_expr <- xml_find_all(xml, consecutive_suppress_xpath)
+    consecutive_suppress_call_text <- xp_call_name(consecutive_suppress_expr)
+    consecutive_suppress_message <- glue(
+      "Unify consecutive calls to {consecutive_suppress_call_text}(). ",
+      "You can do so by writing all of the calls in one braced expression ",
+      "like {consecutive_suppress_call_text}({{...}})."
+    )
+    consecutive_suppress_lints <- xml_nodes_to_lints(
+      consecutive_suppress_expr,
+      source_expression = source_expression,
+      lint_message = consecutive_suppress_message,
+      type = "warning"
+    )
+
+    c(upfront_call_lints, char_only_direct_lints, char_only_indirect_lints, consecutive_suppress_lints)
   })
 }

tests/testthat/test-library_call_linter.R

@@ -114,10 +114,16 @@ test_that("library_call_linter warns on disallowed usages", {
     trim_some("
       library(dplyr)
       print('test')
+      suppressMessages(library('lubridate', character.only = TRUE))
       suppressMessages(library(tidyr))
       print('test')
     "),
-    lint_message,
+    list(
+      list(rex::rex("Unify consecutive calls to suppressMessages()"), line_number = 3L),
+      list(lint_message, line_number = 3L),
+      list(rex::rex("Use symbols in library calls to avoid the need for 'character.only'"), line_number = 3L),
+      list(lint_message, line_number = 4L)
+    ),
     linter
   )
 })
@@ -311,3 +317,123 @@ test_that("multiple lints are generated correctly", {
     library_call_linter()
   )
 })
+
+patrick::with_parameters_test_that(
+  "library_call_linter skips allowed usages",
+  {
+    linter <- library_call_linter()
+
+    expect_lint(sprintf("%s(x)", call), NULL, linter)
+    expect_lint(sprintf("%s(x, y, z)", call), NULL, linter)
+
+    # intervening expression
+    expect_lint(sprintf("%1$s(x); y; %1$s(z)", call), NULL, linter)
+
+    # inline or potentially with gaps don't matter
+    lines <- c(
+      sprintf("%s(x)", call),
+      "y",
+      "",
+      "stopifnot(z)"
+    )
+    expect_lint(lines, NULL, linter)
+
+    # only suppressing calls with library()
+    lines_consecutive <- c(
+      sprintf("%s(x)", call),
+      sprintf("%s(y)", call)
+    )
+    expect_lint(lines_consecutive, NULL, linter)
+  },
+  .test_name = c("suppressMessages", "suppressPackageStartupMessages"),
+  call = c("suppressMessages", "suppressPackageStartupMessages")
+)
+
+patrick::with_parameters_test_that(
+  "library_call_linter blocks simple disallowed usages",
+  {
+    linter <- library_call_linter()
+    message <- sprintf("Unify consecutive calls to %s\\(\\)\\.", call)
+
+    # one test of inline usage
+    expect_lint(sprintf("%1$s(library(x)); %1$s(library(y))", call), message, linter)
+
+    lines_gap <- c(
+      sprintf("%s(library(x))", call),
+      "",
+      sprintf("%s(library(y))", call)
+    )
+    expect_lint(lines_gap, message, linter)
+
+    lines_consecutive <- c(
+      sprintf("%s(require(x))", call),
+      sprintf("%s(require(y))", call)
+    )
+    expect_lint(lines_consecutive, message, linter)
+
+    lines_comment <- c(
+      sprintf("%s(library(x))", call),
+      "# a comment on y",
+      sprintf("%s(library(y))", call)
+    )
+    expect_lint(lines_comment, message, linter)
+  },
+  .test_name = c("suppressMessages", "suppressPackageStartupMessages"),
+  call = c("suppressMessages", "suppressPackageStartupMessages")
+)
+
+test_that("Namespace differences are detected", {
+  linter <- library_call_linter()
+
+  # totally different namespaces
+  expect_lint(
+    "ns::suppressMessages(library(x)); base::suppressMessages(library(y))",
+    NULL,
+    linter
+  )
+
+  # one namespaced, one not
+  expect_lint(
+    "ns::suppressMessages(library(x)); suppressMessages(library(y))",
+    NULL,
+    linter
+  )
+})
+
+test_that("Consecutive calls to different blocked calls is OK", {
+  expect_lint(
+    "suppressPackageStartupMessages(library(x)); suppressMessages(library(y))",
+    NULL,
+    library_call_linter()
+  )
+})
+
+test_that("Multiple violations across different calls are caught", {
+  linter <- library_call_linter()
+
+  expect_lint(
+    trim_some("
+      suppressPackageStartupMessages(library(x))
+      suppressPackageStartupMessages(library(x))
+      suppressMessages(library(x))
+      suppressMessages(library(x))
+    "),
+    list(
+      "Unify consecutive calls to suppressPackageStartupMessages",
+      "Unify consecutive calls to suppressMessages"
+    ),
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+      suppressMessages(library(A))
+      suppressPackageStartupMessages(library(A))
+      suppressMessages(library(A))
+      suppressPackageStartupMessages(library(A))
+      suppressPackageStartupMessages(library(A))
+    "),
+    list("Unify consecutive calls to suppressPackageStartupMessages", line_number = 4L),
+    linter
+  )
+})