Collect more reliable trace_env

NAMESPACE

@@ -106,8 +106,10 @@ export(expect_more_than)
 export(expect_named)
 export(expect_no_condition)
 export(expect_no_error)
+export(expect_no_failure)
 export(expect_no_match)
 export(expect_no_message)
+export(expect_no_success)
 export(expect_no_warning)
 export(expect_null)
 export(expect_output)
@@ -119,6 +121,7 @@ export(expect_setequal)
 export(expect_silent)
 export(expect_snapshot)
 export(expect_snapshot_error)
+export(expect_snapshot_failure)
 export(expect_snapshot_file)
 export(expect_snapshot_output)
 export(expect_snapshot_value)

NEWS.md

@@ -1,5 +1,7 @@
 # testthat (development version)
 
+* New `expect_no_failures()`, `expect_no_successes()` and `expect_snapshot_failure()` provide more options for testing expectations.
+* `expect_error()` and friends no longer give an uninformation error if they fail inside a magrittr pipe (#1994).
 * `expect_true()` and `expect_false()` give better errors if `actual` isn't a vector (#1996).
 * `expect_no_*()` expectations no longer incorrectly emit a passing test result if they in fact fail (#1997).
 * Require the latest version of waldo (0.6.0) in order to get the latest goodies (#1955).

R/expect-condition.R

@@ -163,8 +163,7 @@ expect_warning <- function(object,
       ...,
       inherit = inherit,
       info = info,
-      label = label,
-      trace_env = caller_env()
+      label = label
     )
   } else {
     act <- quasi_capture(enquo(object), label, capture_warnings, ignore_deprecation = identical(regexp, NA))
@@ -196,8 +195,7 @@ expect_message <- function(object,
       ...,
       inherit = inherit,
       info = info,
-      label = label,
-      trace_env = caller_env()
+      label = label
     )
   } else {
     act <- quasi_capture(enquo(object), label, capture_messages)
@@ -225,8 +223,7 @@ expect_condition <- function(object,
       ...,
       inherit = inherit,
       info = info,
-      label = label,
-      trace_env = caller_env()
+      label = label
     )
   } else {
 
@@ -256,6 +253,7 @@ expect_condition_matching <- function(base_class,
                                       label = NULL,
                                       trace_env = caller_env(),
                                       error_call = caller_env()) {
+
   check_dots_used(error = function(cnd) {
     warn(conditionMessage(cnd), call = error_call)
   })
@@ -267,7 +265,7 @@ expect_condition_matching <- function(base_class,
     ...,
     inherit = inherit,
     ignore_deprecation = base_class == "warning" && identical(regexp, NA),
-    error_call = trace_env
+    error_call = error_call
   )
 
   act <- quasi_capture(

R/expect-no-condition.R

@@ -82,10 +82,10 @@ expect_no_condition <- function(object,
 
 
 expect_no_ <- function(base_class,
-                            object,
-                            regexp = NULL,
-                            class = NULL,
-                            error_call = caller_env()) {
+                       object,
+                       regexp = NULL,
+                       class = NULL,
+                       trace_env = caller_env()) {
 
   matcher <- cnd_matcher(
     base_class,
@@ -116,7 +116,7 @@ expect_no_ <- function(base_class,
           indent_lines(rlang::cnd_message(cnd))
         )
         message <- format_error_bullets(c(expected, i = actual))
-        fail(message, trace_env = error_call)
+        fail(message, trace_env = trace_env)
       }
     )
   }

R/expect-self-test.R

@@ -1,23 +1,56 @@
+capture_failure <- new_capture("expectation_failure")
+capture_success <- function(expr) {
+  cnd <- NULL
+
+  withCallingHandlers(
+    expr,
+    expectation_failure = function(cnd) {
+      invokeRestart("continue_test")
+    },
+    expectation_success = function(cnd) {
+      cnd <<- cnd
+    }
+  )
+  cnd
+}
+
+new_capture("expectation_success")
+
 #' Tools for testing expectations
 #'
-#' Use these expectations to test other expectations.
+#' @description
+#' * `expect_sucess()` and `expect_failure()` checks that there's at least
+#'   one success or failure respectively.
+#' * `expect_snapshot_failure()` records the failure message so that you can
+#'   manually check that it is informative.
+#' * `expect_no_success()` and `expect_no_failure()` check that are no
+#'   failures or successes.
+#'
 #' Use `show_failure()` in examples to print the failure message without
 #' throwing an error.
 #'
-#' @param expr Expression that evaluates a single expectation.
+#' @param expr Code to evalute
 #' @param message Check that the failure message matches this regexp.
 #' @param ... Other arguments passed on to [expect_match()].
 #' @export
 expect_success <- function(expr) {
-  exp <- capture_expectation(expr)
+  exp <- capture_success(expr)
 
   if (is.null(exp)) {
-    fail("no expectation used.")
-  } else if (!expectation_success(exp)) {
-    fail(paste0(
-      "Expectation did not succeed:\n",
-      exp$message
-    ))
+    fail("Expectation did not succeed")
+  } else {
+    succeed()
+  }
+  invisible(NULL)
+}
+
+#' @export
+#' @rdname expect_success
+expect_no_success <- function(expr) {
+  exp <- capture_success(expr)
+
+  if (!is.null(exp)) {
+    fail("Expectation succeeded")
   } else {
     succeed()
   }
@@ -27,19 +60,31 @@
 #' @export
 #' @rdname expect_success
 expect_failure <- function(expr, message = NULL, ...) {
-  exp <- capture_expectation(expr)
+  exp <- capture_failure(expr)
 
   if (is.null(exp)) {
-    fail("No expectation used")
-    return()
-  }
-  if (!expectation_failure(exp)) {
     fail("Expectation did not fail")
-    return()
+  } else if (!is.null(message)) {
+    expect_match(exp$message, message, ...)
+  } else {
+    succeed()
   }
+  invisible(NULL)
+}
 
-  if (!is.null(message)) {
-    expect_match(exp$message, message, ...)
+#' @export
+#' @rdname expect_success
+expect_snapshot_failure <- function(expr) {
+  expect_snapshot_error(expr, "expectation_failure")
+}
+
+#' @export
+#' @rdname expect_success
+expect_no_failure <- function(expr) {
+  exp <- capture_failure(expr)
+
+  if (!is.null(exp)) {
+    fail("Expectation failed")
   } else {
     succeed()
   }
@@ -67,10 +112,6 @@
   invisible()
 }
 
-expect_snapshot_failure <- function(x) {
-  expect_snapshot_error(x, "expectation_failure")
-}
-
 expect_snapshot_reporter <- function(reporter, paths = test_path("reporters/tests.R")) {
   local_options(rlang_trace_format_srcrefs = FALSE)
   local_rng_version("3.3")

tests/testthat/test-expect-condition.R

@@ -76,6 +76,12 @@ test_that("can capture Throwable conditions from rJava", {
   expect_error(throw("foo"), "foo", class = "Throwable")
 })
 
+test_that("capture correct trace_env (#1994)", {
+  # This should fail, not error
+  expect_failure(expect_error(stop("oops")) %>% expect_warning())
+  expect_failure(expect_warning(expect_error(stop("oops"))))
+})
+
 # expect_warning() ----------------------------------------------------------
 
 test_that("warnings are converted to errors when options('warn') >= 2", {

tests/testthat/test-expect-no-condition.R

@@ -14,20 +14,13 @@ test_that("expect_no_* conditions behave as expected", {
 })
 
 test_that("expect_no_* don't emit success when they fail", {
+  expect_no_success(expect_no_error(stop("!")))
+})
 
-  catch_cnds <- function(code) {
-    cnds <- list()
-
-    withCallingHandlers(code, condition = function(cnd) {
-      cnds[[length(cnds) + 1]] <<- cnd
-      invokeRestart("continue_test")
-    })
-    cnds
-  }
-
-  cnds <- catch_cnds(expect_no_error(stop("!")))
-  expect_length(cnds, 1)
-  expect_s3_class(cnds[[1]], "expectation_failure")
+test_that("capture correct trace_env (#1994)", {
+  # This should fail, not error
+  expect_failure(expect_message({message("a"); warn("b")}) %>% expect_no_warning())
+  expect_failure(expect_no_message({message("a"); warn("b")}) %>% expect_warning())
 })
 
 test_that("unmatched conditions bubble up", {