New allow_outer_calls argument

R/nested_pipe_linter.R

@@ -3,13 +3,12 @@
 #' Nesting pipes harms readability; extract sub-steps to separate variables,
 #'   append further pipeline steps, or otherwise refactor such usage away.
 #'
-#' When [try()] or [tryCatch()] are the "outer" call, no lint is thrown,
-#'   since the "unnested" version of such usage may not work as intended
-#'   due to how evaluation happens in such cases.
-#'
 #' @param allow_inline Logical, default `TRUE`, in which case only "inner"
 #'   pipelines which span more than one line are linted. If `FALSE`, even
 #'   "inner" pipelines that fit in one line are linted.
+#' @param allow_outer_calls Character vector dictating which "outer"
+#'   calls to exempt from the requirement to unnest (see examples). Defaults
+#'   to [try()], [tryCatch()], and [withCallingHandlers()].
 #'
 #' @examples
 #' # will produce lints
@@ -25,12 +24,24 @@
 #'   linters = nested_pipe_linter(allow_inline = FALSE)
 #' )
 #'
+#' lint(
+#'   text = "tryCatch(x %>% filter(grp == 'a'), error = identity)",
+#'   linters = nested_pipe_linter(allow_outer_calls = character())
+#' )
+#'
 #' # okay
 #' lint(
 #'   text = "df1 %>% inner_join(df2 %>% select(a, b))",
 #'   linters = nested_pipe_linter()
 #' )
 #'
+#' code <- "df1 %>%\n  inner_join(df2 %>%\n    select(a, b)\n  )"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = nested_pipe_linter(allow_outer_calls = "inner_join")
+#' )
+#'
 #' lint(
 #'   text = "tryCatch(x %>% filter(grp == 'a'), error = identity)",
 #'   linters = nested_pipe_linter()
@@ -39,12 +50,14 @@
 #' @evalRd rd_tags("nested_pipe_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-nested_pipe_linter <- function(allow_inline = TRUE) {
+nested_pipe_linter <- function(
+    allow_inline = TRUE,
+    allow_outer_calls = c("try", "tryCatch", "withCallingHandlers")) {
   multiline_and <- if (allow_inline) "@line1 != @line2 and" else ""
   xpath <- glue("
   (//PIPE | //SPECIAL[{ xp_text_in_table(magrittr_pipes) }])
     /parent::expr[{multiline_and} preceding-sibling::expr/SYMBOL_FUNCTION_CALL[
-      not(text() = 'try' or text() = 'tryCatch')
+      not({ xp_text_in_table(allow_outer_calls) })
       and (
         text() != 'switch'
         or parent::expr

tests/testthat/test-nested_pipe_linter.R

@@ -37,12 +37,24 @@ test_that("nested_pipe_linter skips allowed usages", {
     NULL,
     linter
   )
-
-  # try/tryCatch must be evaluated inside the call
-  expect_lint("try(x %>% foo())", NULL, linter)
-  expect_lint("tryCatch(x %>% foo(), error = identity)", NULL, linter)
 })
 
+patrick::with_parameters_test_that(
+  "allow_outer_calls defaults are ignored by default",
+  expect_lint(
+    trim_some(sprintf(outer_call, fmt = "
+      %s(
+        x %%>%%
+          foo()
+      )
+    ")),
+    NULL,
+    nested_pipe_linter()
+  ),
+  .test_name = c("try", "tryCatch", "withCallingHandlers"),
+  outer_call = c("try", "tryCatch", "withCallingHandlers")
+)
+
 test_that("nested_pipe_linter blocks simple disallowed usages", {
   linter <- nested_pipe_linter()
   linter_inline <- nested_pipe_linter(allow_inline = FALSE)
@@ -90,6 +102,30 @@ test_that("nested_pipe_linter blocks simple disallowed usages", {
   )
 })
 
+test_that("allow_outer_calls= argument works", {
+  expect_lint(
+    trim_some("
+      try(
+        x %>%
+          foo()
+      )
+    "),
+    rex::rex("Don't nest pipes inside other calls."),
+    nested_pipe_linter(allow_outer_calls = character())
+  )
+
+  expect_lint(
+    trim_some("
+      print(
+        x %>%
+          foo()
+      )
+    "),
+    NULL,
+    nested_pipe_linter(allow_outer_calls = "print")
+  )
+})
+
 test_that("Native pipes are handled as well", {
   skip_if_not_r_version("4.1.0")