Make interactive snapshot output a bit more obvious (#2000)

Testing this change revealed a bug in `test_code()`: specifying the default reporter happened _after_ `local_test_context()` meaning that it failed to capture the actual user settings. I fixed this by now requiring a reporter (rather than a backup reporter). It also revealed a bug in the width computation for issue headings 😬 

Fixes #1992

Co-authored-by: Davis Vaughan <davis@posit.co>

R/describe.R

@@ -76,13 +76,14 @@ describe <- function(description, code) {
 }
 
 describe_it <- function(description, code, env = parent.frame()) {
+  reporter <- get_reporter() %||% local_interactive_reporter()
   local_test_context()
 
   test_code(
     description,
     code,
     env = env,
-    default_reporter = local_interactive_reporter(),
+    reporter = reporter,
     skip_on_empty = FALSE
   )
 }

R/reporter-progress.R

@@ -534,7 +534,9 @@ issue_header <- function(x, pad = FALSE) {
 issue_summary <- function(x, rule = FALSE) {
   header <- cli::style_bold(issue_header(x))
   if (rule) {
-    header <- cli::rule(header, width = max(cli::ansi_nchar(header) + 6, 80))
+    # Don't truncate long test names
+    width <- max(cli::ansi_nchar(header) + 6, getOption("width"))
+    header <- cli::rule(header, width = width)
   }
 
   paste0(header, "\n", format(x))

R/snapshot-file.R

@@ -101,7 +101,7 @@ expect_snapshot_file <- function(path,
 
   snapshotter <- get_snapshotter()
   if (is.null(snapshotter)) {
-    snapshot_not_available(paste0("New path: ", path))
+    snapshot_not_available(path)
     return(invisible())
   }
 

R/snapshot.R

@@ -272,7 +272,7 @@ expect_snapshot_helper <- function(lab, val,
 
   snapshotter <- get_snapshotter()
   if (is.null(snapshotter)) {
-    snapshot_not_available(paste0("Current value:\n", save(val)))
+    snapshot_not_available(save(val))
     return(invisible())
   }
 
@@ -323,11 +323,14 @@ snapshot_accept_hint <- function(variant, file, reset_output = TRUE) {
 }
 
 snapshot_not_available <- function(message) {
+  local_reporter_output()
+
+  cat(cli::rule("Snapshot"), "\n", sep = "")
   cli::cli_inform(c(
-    "{.strong Can't compare snapshot to reference when testing interactively.}",
-    i = "Run {.run devtools::test()} or {.code testthat::test_file()} to see changes."
+    i = "Can't save or compare to reference when testing interactively."
   ))
   cat(message, "\n", sep = "")
+  cat(cli::rule(), "\n", sep = "")
 }
 
 local_snapshot_dir <- function(snap_names, .env = parent.frame()) {

R/source.R

@@ -44,7 +44,7 @@ source_file <- function(path,
       test = NULL,
       code = exprs,
       env = env,
-      default_reporter = StopReporter$new()
+      reporter = get_reporter() %||% StopReporter$new()
     ))
   } else {
     withCallingHandlers(

R/test-example.R

@@ -65,7 +65,7 @@ test_example <- function(path, title = path) {
     test = title,
     code = parse(ex_path, encoding = "UTF-8"),
     env = env,
-    default_reporter = StopReporter$new(),
+    reporter = get_reporter() %||% StopReporter$new(),
     skip_on_empty = FALSE
   )
   if (ok) succeed(path)

R/test-that.R

@@ -46,21 +46,23 @@ 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(),
-    default_reporter = local_interactive_reporter()
+    reporter = reporter
   )
 }
 
 # Access error fields with `[[` rather than `$` because the
 # `$.Throwable` from the rJava package throws with unknown fields
-test_code <- function(test, code, env, default_reporter, skip_on_empty = TRUE) {
+test_code <- function(test, code, env, reporter, skip_on_empty = TRUE) {
 
   frame <- caller_env()
-  reporter <- get_reporter() %||% default_reporter
 
   if (!is.null(test)) {
     reporter$start_test(context = reporter$.context, test = test)

tests/testthat/test-snapshot-reporter.R

@@ -14,8 +14,8 @@ test_that("basic workflow", {
   snapper$start_file("snapshot-2")
   # output if not active (because test not set here)
   expect_snapshot_output("x") %>%
-    expect_message("Can't compare") %>%
-    expect_output("Current value:\n[1] \"x\"", fixed = TRUE)
+    expect_message("Can't save") %>%
+    expect_output("[1] \"x\"", fixed = TRUE)
 
   # warns on first creation
   snapper$start_file("snapshot-2", "test")