Merged origin/main into comparison-display

Author: hadley

.claude/settings.local.json

@@ -9,4 +9,4 @@
     ],
     "deny": []
   }
-}
+}

NEWS.md

@@ -1,6 +1,8 @@
 # testthat (development version)
 
 * `expect_lt()`, `expect_gt()`, and friends have a refined display that is more likely to display the correct number of digits and shows you the actual values compared.
+* `describe()`, `it()`, and `test_that()` now have a shared stack of descriptions so that if you nest any inside of each other, any resulting failures will show you the full path.
+* `describe()` now correctly scopes `skip()` (#2007).
 * `ParallelProgressReporter` now respect `max_failures` (#1162).
 * The last snapshot is no longer lost if the snapshot file is missing the final newline (#2092). It's easy to accidentally remove this because there are two trailing new lines in snapshot files and many editors will automatically remove if you touch the file.
 * New `expect_r6_class()` (#2030).

R/describe.R

@@ -56,43 +56,17 @@
 #'     it("can handle division by 0") #not yet implemented
 #'   })
 #' })
-
 describe <- function(description, code) {
-  check_string(description, allow_empty = FALSE)
-  describe_description <- description
-
-  # prepares a new environment for each it-block
-  describe_environment <- new.env(parent = parent.frame())
-  describe_environment$it <- function(description, code = NULL) {
-    check_string(description, allow_empty = FALSE)
-    code <- substitute(code)
-
-    description <- paste0(describe_description, ": ", description)
-    describe_it(description, code, describe_environment)
-  }
-
-  eval(substitute(code), describe_environment)
-  invisible()
-}
-
-describe_it <- function(description, code, env = parent.frame()) {
-  reporter <- get_reporter() %||% local_interactive_reporter()
-  local_test_context()
+  local_description_push(description)
 
-  test_code(
-    description,
-    code,
-    env = env,
-    reporter = reporter,
-    skip_on_empty = FALSE
-  )
+  test_code(code, parent.frame(), skip_on_empty = FALSE)
 }
 
 #' @export
 #' @rdname describe
 it <- function(description, code = NULL) {
-  check_string(description, allow_empty = FALSE)
+  local_description_push(description)
 
   code <- substitute(code)
-  describe_it(description, code, env = parent.frame())
+  test_code(code, env = parent.frame(), skip_on_empty = FALSE)
 }

R/reporter-silent.R

@@ -28,3 +28,11 @@ SilentReporter <- R6::R6Class(
     }
   )
 )
+
+# Useful for testing test_that() and friends which otherwise swallow
+# all expectations by design
+capture_expectations <- function(code) {
+  reporter <- SilentReporter$new()
+  with_reporter(reporter, code)
+  reporter$expectations()
+}

R/reporter-zzz.R

@@ -36,6 +36,8 @@ get_reporter <- function() {
 #' @rdname reporter-accessors
 #' @export
 with_reporter <- function(reporter, code, start_end_reporter = TRUE) {
+  # Ensure we don't propagate the local description to the new reporter
+  local_description_set()
   reporter <- find_reporter(reporter)
 
   old <- set_reporter(reporter)

R/snapshot-reporter.R

@@ -35,9 +35,11 @@ SnapshotReporter <- R6::R6Class(
     },
 
     start_test = function(context, test) {
-      if (is.character(test)) {
-        self$test <- gsub("\n", "", test)
+      if (is.null(test)) {
+        return()
       }
+
+      self$test <- paste0(gsub("\n", "", test), collapse = " / ")
     },
 
     # Called by expectation

R/source.R

@@ -55,7 +55,6 @@ source_file <- function(
   withr::local_options(testthat_topenv = env, testthat_path = path)
   if (wrap) {
     invisible(test_code(
-      test = NULL,
       code = exprs,
       env = env,
       reporter = get_reporter() %||% StopReporter$new()

R/test-example.R

@@ -47,24 +47,23 @@ test_examples_installed <- function(package = testing_package()) {
 #' @export
 #' @rdname test_examples
 test_rd <- function(rd, title = attr(rd, "Rdfile")) {
-  test_example(rd, title)
+  test_example(rd, title %||% "example")
 }
 
 #' @export
 #' @rdname test_examples
 test_example <- function(path, title = path) {
+  local_description_push(title)
+
   ex_path <- withr::local_tempfile(pattern = "test_example-", fileext = ".R")
   tools::Rd2ex(path, ex_path)
   if (!file.exists(ex_path)) {
     return(invisible(FALSE))
   }
 
-  env <- new.env(parent = globalenv())
-
   ok <- test_code(
-    test = title,
     code = parse(ex_path, encoding = "UTF-8"),
-    env = env,
+    env = globalenv(),
     reporter = get_reporter() %||% StopReporter$new(),
     skip_on_empty = FALSE
   )

R/test-that.R

@@ -34,7 +34,7 @@
 #' })
 #' }
 test_that <- function(desc, code) {
-  check_string(desc)
+  local_description_push(desc)
 
   code <- substitute(code)
   if (edition_get() >= 3) {
@@ -46,23 +46,19 @@ test_that <- function(desc, code) {
     }
   }
 
-  # Must initialise interactive reporter before local_test_context()
-  reporter <- get_reporter() %||% local_interactive_reporter()
-  local_test_context()
-
-  test_code(
-    desc,
-    code,
-    env = parent.frame(),
-    reporter = reporter
-  )
+  test_code(code, env = parent.frame())
 }
 
 # Access error fields with `[[` rather than `$` because the
 # `$.Throwable` from the rJava package throws with unknown fields
-test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
+test_code <- function(code, env, reporter = NULL, skip_on_empty = TRUE) {
+  # Must initialise interactive reporter before local_test_context()
+  reporter <- get_reporter() %||% local_interactive_reporter()
+  local_test_context()
+
   frame <- caller_env()
 
+  test <- test_description()
   if (!is.null(test)) {
     reporter$start_test(context = reporter$.context, test = test)
     withr::defer(reporter$end_test(context = reporter$.context, test = test))
@@ -89,11 +85,6 @@ test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
     reporter$add_result(context = reporter$.context, test = test, result = e)
   }
 
-  # Any error will be assigned to this variable first
-  # In case of stack overflow, no further processing (not even a call to
-  # signalCondition() ) might be possible
-  test_error <- NULL
-
   expressions_opt <- getOption("expressions")
   expressions_opt_new <- min(expressions_opt + 500L, 500000L)
 
@@ -104,39 +95,21 @@ test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
 
   handle_error <- function(e) {
     handled <<- TRUE
-    # First thing: Collect test error
-    test_error <<- e
 
     # Increase option(expressions) to handle errors here if possible, even in
-    # case of a stack overflow.  This is important for the DebugReporter.
-    # Call options() manually, avoid withr overhead.
-    options(expressions = expressions_opt_new)
-    withr::defer(options(expressions = expressions_opt))
+    # case of a stack overflow. This is important for the DebugReporter.
+    local_options(expressions = expressions_opt_new)
 
     # Add structured backtrace to the expectation
     if (can_entrace(e)) {
       e <- cnd_entrace(e)
     }
 
-    test_error <<- e
-
-    # Error will be handled by handle_fatal() if this fails; need to do it here
-    # to be able to debug with the DebugReporter
     register_expectation(e, 2)
-
-    e[["handled"]] <- TRUE
-    test_error <<- e
+    invokeRestart("end_test")
   }
   handle_fatal <- function(e) {
     handled <<- TRUE
-    # Error caught in handle_error() has precedence
-    if (!is.null(test_error)) {
-      e <- test_error
-      if (isTRUE(e[["handled"]])) {
-        return()
-      }
-    }
-
     register_expectation(e, 0)
   }
   handle_expectation <- function(e) {
@@ -162,7 +135,6 @@ test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
     }
 
     register_expectation(e, 5)
-
     tryInvokeRestart("muffleWarning")
   }
   handle_message <- function(e) {
@@ -175,7 +147,7 @@ test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
 
     debug_end <- if (inherits(e, "skip_empty")) -1 else 2
     register_expectation(e, debug_end)
-    signalCondition(e)
+    invokeRestart("end_test")
   }
 
   test_env <- new.env(parent = env)
@@ -185,24 +157,25 @@ test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
   withr::local_options(testthat_topenv = test_env)
 
   before <- inspect_state()
-  tryCatch(
-    withCallingHandlers(
-      {
-        eval(code, test_env)
-        if (!handled && !is.null(test)) {
-          skip_empty()
-        }
-      },
-      expectation = handle_expectation,
-      skip = handle_skip,
-      warning = handle_warning,
-      message = handle_message,
-      error = handle_error
+  withRestarts(
+    tryCatch(
+      withCallingHandlers(
+        {
+          eval(code, test_env)
+          if (!handled && !is.null(test)) {
+            skip_empty()
+          }
+        },
+        expectation = handle_expectation,
+        skip = handle_skip,
+        warning = handle_warning,
+        message = handle_message,
+        error = handle_error
+      ),
+      # some errors may need handling here, e.g., stack overflow
+      error = handle_fatal
     ),
-    # some errors may need handling here, e.g., stack overflow
-    error = handle_fatal,
-    # skip silently terminate code
-    skip = function(e) {}
+    end_test = function() {}
   )
   after <- inspect_state()
 
@@ -215,3 +188,30 @@ test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
 
   invisible(ok)
 }
+
+
+# Maintain a stack of descriptions
+local_description_push <- function(description, frame = caller_env()) {
+  check_string(description, call = frame)
+  local_description_set(c(the$description, description), frame = frame)
+}
+local_description_set <- function(
+  description = character(),
+  frame = caller_env()
+) {
+  check_character(description, call = frame)
+
+  old <- the$description
+  the$description <- description
+  withr::defer(the$description <- old, frame)
+
+  invisible(old)
+}
+
+test_description <- function() {
+  if (length(the$description) == 0) {
+    NULL
+  } else {
+    paste(the$description, collapse = " / ")
+  }
+}

R/testthat-package.R

@@ -19,7 +19,7 @@
 NULL
 
 the <- new.env(parent = emptyenv())
-
+the$description <- character()
 
 # The following block is used by usethis to automatically manage
 # roxygen namespace tags. Modify with care!