Extract a reprex from a failing expectation

NAMESPACE

@@ -142,6 +142,7 @@ export(expect_vector)
 export(expect_visible)
 export(expect_warning)
 export(expectation)
+export(extract_test)
 export(fail)
 export(find_test_scripts)
 export(get_reporter)

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* New `extract_test()` function to extract a reprex from a failing expectation.
 * `expect_all_equal()`, `expect_all_true()`, and `expect_all_false()` are a new family of expectations that checks that every element of a vector has the same value. Compared to using `expect_true(all(...))` they give better failure messages (#1836, #2235).
 * Expectations now consistently return the value of the first argument, regardless of whether the expectation succeeds or fails. The primary exception are `expect_message()` and friends which will return the condition. This shouldn't affect existing tests, but will make failures clearer when you chain together multiple expectations (#2246).
 * `set_state_inspector()` gains `tolerance` argument and ignores minor FP differences by default (@mcol, #2237).

R/extract.R

@@ -0,0 +1,119 @@
+#' Extract a reprex from a failed expectation
+#'
+#' @description
+#' `extract_test()` creates a minimal reprex for a failed expectation.
+#' It extracts all non-test code before the failed expectation as well as
+#' all code inside the test up to and including the failed expectation.
+#'
+#' This is particularly useful when you're debugging test failures in
+#' someone else's package.
+#'
+#' @param location A string giving the location in the form
+#'   `FILE:LINE[:COLUMN]`.
+#' @param path Path to write the reprex to. Defaults to `stdout()`.
+#' @return This function is called for its side effect of rendering a
+#'   reprex to `path`. This function will never error: if extraction
+#'   fails, the error message will be written to `path`.
+#' @export
+#' @examples
+#' # If you see a test failure like this:
+#' # ── Failure (test-extract.R:46:3): errors if can't find test ───────────────
+#' # Expected FALSE to be TRUE.
+#' # Differences:
+#' # `actual`:   FALSE
+#' # `expected`: TRUE
+#'
+#' # You can run this:
+#' \dontrun{extract_test("test-extract.R:46:3")}
+#' # to see just the code needed to reproduce the failure
+extract_test <- function(location, path = stdout()) {
+  check_string(location)
+
+  pieces <- strsplit(location, ":")[[1]]
+  if (!length(pieces) %in% c(2, 3)) {
+    cli::cli_abort(
+      "Expected {.arg location} to be of the form FILE:LINE[:COLUMN]"
+    )
+  }
+
+  test_path <- test_path(pieces[[1]])
+  line <- as.integer(pieces[2])
+  source <- paste0("# Extracted from ", test_path, ":", line)
+  exprs <- parse_file(test_path)
+
+  lines <- tryCatch(
+    extract_test_lines(exprs, line),
+    error = function(cnd) {
+      lines <- strsplit(conditionMessage(cnd), "\n")[[1]]
+      lines <- c("", "Failed to extract test: ", lines)
+      paste0("# ", lines)
+    }
+  )
+  lines <- c(source, lines)
+
+  base::writeLines(lines, con = path)
+}
+
+extract_test_lines <- function(exprs, line, error_call = caller_env()) {
+  check_number_whole(line, min = 1, call = error_call)
+
+  srcrefs <- attr(exprs, "srcref")
+  is_subtest <- map_lgl(exprs, is_subtest)
+
+  # First we find the test
+  is_test <- is_subtest &
+    start_line(srcrefs) <= line &
+    end_line(srcrefs) >= line
+  if (!any(is_test)) {
+    cli::cli_abort("Failed to find test at line {line}.", call = error_call)
+  }
+  call <- exprs[[which(is_test)[[1]]]]
+  test_contents <- attr(call[[3]], "srcref")[-1] # drop `{`
+  keep <- start_line(test_contents) <= line
+  test <- srcref_to_character(test_contents[keep])
+
+  # We first find the prequel, all non-test code before the test
+  is_prequel <- !is_subtest & start_line(srcrefs) < line
+  if (!any(is_prequel)) {
+    return(test)
+  }
+
+  c(
+    "# prequel ---------------------------------------------------------------",
+    srcref_to_character(srcrefs[is_prequel]),
+    "",
+    "# test ------------------------------------------------------------------",
+    test
+  )
+}
+
+# Helpers ---------------------------------------------------------------------
+
+parse_file <- function(path, error_call = caller_env()) {
+  check_string(path, call = error_call)
+  if (!file.exists(path)) {
+    cli::cli_abort(
+      "{.arg path} ({.path path}) does not exist.",
+      call = error_call
+    )
+  }
+  parse(path, keep.source = TRUE)
+}
+
+parse_text <- function(text) {
+  text <- sub("^\n", "", text)
+  indent <- regmatches(text, regexpr("^ *", text))
+  text <- gsub(paste0("(?m)^", indent), "", text, perl = TRUE)
+
+  parse(text = text, keep.source = TRUE)
+}
+
+srcref_to_character <- function(x) {
+  unlist(map(x, as.character))
+}
+start_line <- function(srcrefs) {
+  map_int(srcrefs, \(x) x[[1]])
+}
+end_line <- function(srcrefs) {
+  map_int(srcrefs, \(x) x[[3]])
+}

R/source.R

@@ -115,7 +115,9 @@ filter_desc <- function(exprs, descs, error_call = caller_env()) {
 }
 
 is_subtest <- function(expr) {
-  is_call(expr, c("test_that", "describe", "it"), n = 2) && is_string(expr[[2]])
+  is_call(expr, c("test_that", "describe", "it"), n = 2) &&
+    is_string(expr[[2]]) &&
+    is_call(expr[[3]], "{")
 }
 
 #' @rdname source_file

_pkgdown.yml

@@ -54,6 +54,7 @@ reference:
 - title: Test helpers
   contents:
   - is_testing
+  - extract_test
   - local_edition
   - local_reproducible_output
   - set_state_inspector

tests/testthat/_snaps/extract.md

@@ -0,0 +1,30 @@
+# can extract prequel
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 4))
+    Output
+      # prequel ---------------------------------------------------------------
+      x <- 1
+      y <- 2
+
+      # test ------------------------------------------------------------------
+      expect_true(TRUE)
+
+# preserves code format but not comments
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 3))
+    Output
+      # prequel ---------------------------------------------------------------
+      1 +   1
+
+      # test ------------------------------------------------------------------
+      2 +   2
+
+# can extract selected expectation
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 2))
+    Output
+      expect_true(TRUE)
+

tests/testthat/test-expect-output.R

@@ -1,6 +1,8 @@
 f <- function() NULL
 g <- function() cat("!")
 
+writeLines("Hi!", "../someoutput.txt")
+
 test_that("expect = NA checks for no output", {
   expect_success(expect_output(f(), NA))
   expect_snapshot_failure(expect_output(g(), NA))

tests/testthat/test-extract.R

@@ -0,0 +1,46 @@
+test_that("can extract prequel", {
+  # fmt: skip
+  exprs <- parse_text("
+    x <- 1
+    y <- 2
+    test_that('foo', {
+      expect_true(TRUE)
+    })
+  ")
+  expect_snapshot(base::writeLines(extract_test_lines(exprs, 4)))
+})
+
+test_that("preserves code format but not comments", {
+  # fmt: skip
+  exprs <- parse_text("
+    1 +   1 # 2
+    test_that('foo', {
+      2 +   2 # 4
+    })
+  ")
+  expect_snapshot(base::writeLines(extract_test_lines(exprs, 3)))
+})
+
+test_that("can extract selected expectation", {
+  # fmt: skip
+  exprs <- parse_text("
+    test_that('foo', {
+      expect_true(TRUE)
+      expect_false(FALSE)
+    })
+  ")
+  expect_snapshot(base::writeLines(extract_test_lines(exprs, 2)))
+})
+
+test_that("errors if can't find test", {
+  # fmt: skip
+  exprs <- parse_text("
+    # line 1
+    test_that('foo', {
+      expect_true(TRUE)
+    })
+    # line 5
+  ")
+  expect_error(extract_test_lines(exprs, 1), "Failed to find test")
+  expect_error(extract_test_lines(exprs, 5), "Failed to find test")
+})