New consecutive_suppression_linter

NAMESPACE

@@ -41,7 +41,6 @@ export(condition_message_linter)
 export(conjunct_test_linter)
 export(consecutive_assertion_linter)
 export(consecutive_stopifnot_linter)
-export(consecutive_suppression_linter)
 export(cyclocomp_linter)
 export(default_linters)
 export(default_settings)

R/consecutive_suppression_linter.R

@@ -5,67 +5,3 @@
 #'   done once, by wrapping the sequence of library calls into
 #'   one `{}` expression, as opposed to repeatedly
 #'
-#' @examples
-#' # will produce lints
-#' code <- "suppressMessages(library(dplyr))\nsuppressMessages(library(tidyr))"
-#' writeLines(code)
-#' lint(
-#'   text = code,
-#'   linters = consecutive_suppression_linter()
-#' )
-#'
-#' # okay
-#' code <- "suppressMessages({\n  library(dplyr)\n  library(tidyr)\n})"
-#' writeLines(code)
-#' lint(
-#'   text = code
-#'   linters = consecutive_suppression_linter()
-#' )
-#'
-#' @evalRd rd_tags("consecutive_suppression_linter")
-#' @seealso [linters] for a complete list of linters available in lintr.
-#' @export
-consecutive_suppression_linter <- function() {
-  suppress_calls <- c("suppressMessages", "suppressPackageStartupMessages")
-  library_calls <- c("library", "require")
-  library_cond <- glue(
-    "expr[expr[SYMBOL_FUNCTION_CALL[{xp_text_in_table(library_calls)}]]]"
-  )
-  # 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.
-  xpath <- glue("
-  //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(suppress_calls) }]
-    /parent::expr
-    /parent::expr[
-      expr[SYMBOL_FUNCTION_CALL[{ xp_text_in_table(suppress_calls) }]]
-        = following-sibling::expr[1][{library_cond}]/expr
-      and {library_cond}
-    ]
-  ")
-
-  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 <- xml_find_all(xml, xpath)
-    call_text <- xp_call_name(bad_expr)
-    lint_message <- glue(
-      "Unify consecutive calls to {call_text}(). ",
-      "You can do so by writing all of the calls in one braced expression ",
-      "like {call_text}({{...}})."
-    )
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = lint_message,
-      type = "warning"
-    )
-  })
-}

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.
 #'
 #' @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 = consecutive_suppression_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 = consecutive_suppression_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 @@
         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 @@
   ")
   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 @@
 
     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,6 @@
       type = "warning"
     )
 
-    c(upfront_call_lints, char_only_direct_lints, char_only_indirect_lints)
+    c(upfront_call_lints, char_only_direct_lints, char_only_indirect_lints, consecutive_suppress_lints)
   })
 }