Don't use snapshot reporter in parent thread (#1793)

* Don't use snapshot reporter in parent thread
* Only delete files if not in main thread and changing working directory higher up
* Remove outdated comment

Author: hadley

NEWS.md

@@ -1,8 +1,5 @@
 # testthat (development version)
 
-* All packages, regardless of whether or not they use rlang, now
-  use the new snapshot display for errors, warnings, and messages.
-
 * `skip_on_cran()` no longer skips (errors) when run interactively.
 
 * `testthat::teardown_env()` works in more cases.

R/edition.R

@@ -81,3 +81,33 @@ edition_get <- function() {
     find_edition(".")
   }
 }
+
+
+find_dep_version <- function(name, path, package = NULL) {
+  desc <- find_description(path, package)
+  if (is.null(desc)) {
+    return(NULL)
+  }
+
+  deps <- desc$get_deps()
+  i <- match(name, deps[["package"]])
+  if (is_na(i)) {
+    return(NULL)
+  }
+
+  dep <- deps[[i, "version"]]
+  dep <- strsplit(dep, " ")[[1]]
+  if (!is_character(dep, 2) && !is_string(dep[[1]], ">=")) {
+    return(NULL)
+  }
+
+  dep[[2]]
+}
+has_dep <- function(name, path, package = NULL) {
+  !is.null(find_dep_version(name, path, package = package))
+}
+
+use_rlang_1_0 <- function() {
+  rlang::is_true(peek_option("testthat:::rlang_dep")) &&
+    is_installed("rlang", version = "0.99.0.9001")
+}

R/local.R

@@ -174,6 +174,10 @@ local_test_directory <- function(path, package = NULL, .env = parent.frame()) {
   # Set edition before changing working directory in case path is relative
   local_edition(find_edition(path, package), .env = .env)
 
+  withr::local_options(
+    "testthat:::rlang_dep" = has_dep("rlang", path, package),
+    .local_envir = .env
+  )
   withr::local_dir(
     path,
     .local_envir = .env

R/parallel.R

@@ -46,7 +46,7 @@ test_files_parallel <- function(
                        ) {
 
 
-  reporters <- test_files_reporter(reporter)
+  reporters <- test_files_reporter(reporter, parallel = TRUE)
 
   # TODO: support timeouts. 20-30s for each file by default?
 
@@ -70,13 +70,15 @@ test_files_parallel <- function(
     load_package = load_package
   )
 
-  with_reporter(reporters$multi, {
-    parallel_updates <- reporter$capabilities$parallel_updates
-    if (parallel_updates) {
-      parallel_event_loop_smooth(queue, reporters, test_dir)
-    } else {
-      parallel_event_loop_chunky(queue, reporters, test_dir)
-    }
+  withr::with_dir(test_dir, {
+    with_reporter(reporters$multi, {
+      parallel_updates <- reporter$capabilities$parallel_updates
+      if (parallel_updates) {
+        parallel_event_loop_smooth(queue, reporters, ".")
+      } else {
+        parallel_event_loop_chunky(queue, reporters, ".")
+      }
+    })
   })
 
   test_files_check(reporters$list$get_results(),

R/snapshot-reporter.R

@@ -9,14 +9,16 @@ SnapshotReporter <- R6::R6Class("SnapshotReporter",
     snap_file_seen = character(),
     variants_changed = FALSE,
     fail_on_new = FALSE,
+    parallel = FALSE,
 
     old_snaps = NULL,
     cur_snaps = NULL,
     new_snaps = NULL,
 
-    initialize = function(snap_dir = "_snaps", fail_on_new = FALSE) {
+    initialize = function(snap_dir = "_snaps", fail_on_new = FALSE, parallel = FALSE) {
       self$snap_dir <- normalizePath(snap_dir, mustWork = FALSE)
       self$fail_on_new <- fail_on_new
+      self$parallel <- parallel
     },
 
     start_file = function(path, test = NULL) {
@@ -127,6 +129,11 @@ SnapshotReporter <- R6::R6Class("SnapshotReporter",
     },
 
     end_file = function() {
+      if (self$parallel) {
+        # This is only needs to be done in the child threads.
+        return()
+      }
+
       dir.create(self$snap_dir, showWarnings = FALSE)
 
       self$cur_snaps$write()
@@ -193,9 +200,13 @@ get_snapshotter <- function() {
 #'
 #' @export
 #' @keywords internal
-local_snapshotter <- function(snap_dir = NULL, cleanup = FALSE, fail_on_new = FALSE, .env = parent.frame()) {
+local_snapshotter <- function(snap_dir = NULL, cleanup = FALSE, fail_on_new = FALSE, parallel = FALSE, .env = parent.frame()) {
   snap_dir <- snap_dir %||% withr::local_tempdir(.local_envir = .env)
-  reporter <- SnapshotReporter$new(snap_dir = snap_dir, fail_on_new = fail_on_new)
+  reporter <- SnapshotReporter$new(
+    snap_dir = snap_dir,
+    fail_on_new = fail_on_new,
+    parallel = parallel
+  )
   if (!identical(cleanup, FALSE)) {
     warn("`cleanup` is deprecated")
   }

R/snapshot.R

@@ -123,6 +123,14 @@ snapshot_replay.condition <- function(x,
                                       ...,
                                       transform = NULL,
                                       cnd_class = FALSE) {
+  if (!use_rlang_1_0()) {
+    return(snapshot_replay_condition_legacy(
+      x,
+      state,
+      transform = transform
+    ))
+  }
+
   cnd_message <- env_get(ns_env("rlang"), "cnd_message")
 
   if (inherits(x, "message")) {
@@ -143,6 +151,27 @@ snapshot_replay.condition <- function(x,
   c(snap_header(state, type), snapshot_lines(msg, transform))
 }
 
+snapshot_replay_condition_legacy <- function(x, state = env(), transform = NULL) {
+  msg <- cnd_message(x)
+
+  if (inherits(x, "error")) {
+    state$error <- x
+    type <- "Error"
+    msg <- add_implicit_nl(msg)
+  } else if (inherits(x, "warning")) {
+    type <- "Warning"
+    msg <- paste0(msg, "\n")
+  } else if (inherits(x, "message")) {
+    type <- "Message"
+  } else {
+    type <- "Condition"
+  }
+
+  class <- paste0(type, " <", class(x)[[1]], ">")
+
+  c(snap_header(state, class), snapshot_lines(msg, transform))
+}
+
 snapshot_lines <- function(x, transform = NULL) {
   x <- split_lines(x)
   if (!is.null(transform)) {

R/test-files.R

@@ -277,12 +277,17 @@ test_files_setup_state <- function(
   withr::defer(source_test_teardown(".", env), frame)      # old school
 }
 
-test_files_reporter <- function(reporter, .env = parent.frame()) {
+test_files_reporter <- function(reporter, .env = parent.frame(), parallel = FALSE) {
   lister <- ListReporter$new()
   reporters <- list(
     find_reporter(reporter),
     lister, # track data
-    local_snapshotter("_snaps", fail_on_new = FALSE, .env = .env) # for snapshots
+    local_snapshotter(
+      "_snaps",
+      fail_on_new = FALSE,
+      parallel = parallel,
+      .env = .env
+    )
   )
   list(
     multi = MultiReporter$new(reporters = compact(reporters)),

man/local_snapshotter.Rd

@@ -0,0 +1,46 @@
+# full condition message is printed with rlang
+
+    Code
+      foo <- error_cnd("foo", message = "Title parent.")
+      abort("Title.", parent = foo)
+    Condition
+      Error:
+      ! Title.
+      Caused by error:
+      ! Title parent.
+
+# can print with and without condition classes
+
+    Code
+      f()
+    Message <simpleMessage>
+      foo
+    Condition <simpleWarning>
+      Warning in `f()`:
+      bar
+    Condition <simpleError>
+      Error in `f()`:
+      ! baz
+
+---
+
+    Code
+      f()
+    Message
+      foo
+    Condition
+      Warning in `f()`:
+      bar
+      Error in `f()`:
+      ! baz
+
+# errors and warnings are folded
+
+    Code
+      f()
+    Condition
+      Warning in `f()`:
+      foo
+      Error in `f()`:
+      ! bar
+

tests/testthat/_snaps/rlang-1.0/snapshot.md

@@ -0,0 +1,39 @@
+# full condition message is printed with rlang
+
+    Code
+      foo <- error_cnd("foo", message = "Title parent.")
+      abort("Title.", parent = foo)
+    Error <rlang_error>
+      Title.
+
+# can print with and without condition classes
+
+    Code
+      f()
+    Message <simpleMessage>
+      foo
+    Warning <simpleWarning>
+      bar
+    Error <simpleError>
+      baz
+
+---
+
+    Code
+      f()
+    Message <simpleMessage>
+      foo
+    Warning <simpleWarning>
+      bar
+    Error <simpleError>
+      baz
+
+# errors and warnings are folded
+
+    Code
+      f()
+    Warning <simpleWarning>
+      foo
+    Error <simpleError>
+      bar
+

tests/testthat/_snaps/rlang-pre-1.0/snapshot.md

@@ -254,52 +254,6 @@
       x <- quote(!!foo)
       expect_equal(x, call("!", call("!", quote(foo))))
 
-# full condition message is printed with rlang
-
-    Code
-      foo <- error_cnd("foo", message = "Title parent.")
-      abort("Title.", parent = foo)
-    Condition
-      Error:
-      ! Title.
-      Caused by error:
-      ! Title parent.
-
-# can print with and without condition classes
-
-    Code
-      f()
-    Message <simpleMessage>
-      foo
-    Condition <simpleWarning>
-      Warning in `f()`:
-      bar
-    Condition <simpleError>
-      Error in `f()`:
-      ! baz
-
----
-
-    Code
-      f()
-    Message
-      foo
-    Condition
-      Warning in `f()`:
-      bar
-      Error in `f()`:
-      ! baz
-
-# errors and warnings are folded
-
-    Code
-      f()
-    Condition
-      Warning in `f()`:
-      foo
-      Error in `f()`:
-      ! bar
-
 # hint is informative
 
     Code

tests/testthat/_snaps/snapshot.md

@@ -0,0 +1,7 @@
+rlang_version <- function() {
+  if (use_rlang_1_0()) "rlang-1.0" else "rlang-pre-1.0"
+}
+
+local_use_rlang_1_0 <- function(frame = caller_env()) {
+  local_options("testthat:::rlang_dep" = TRUE, .frame = frame)
+}