diff --git a/NAMESPACE b/NAMESPACE index 85e3e9679..985a05b7a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -143,6 +143,7 @@ export(expect_vector) export(expect_visible) export(expect_warning) export(expectation) +export(extract_test) export(fail) export(find_test_scripts) export(get_reporter) @@ -185,6 +186,7 @@ export(set_state_inspector) export(setup) export(show_failure) export(shows_message) +export(simulate_test_env) export(skip) export(skip_if) export(skip_if_not) diff --git a/NEWS.md b/NEWS.md index 46b472027..de7f2a741 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,6 +22,7 @@ ## Other new features +* New `extract_test()` function to extract a reprex from a failing expectation. tests run in `R CMD check` will use this to automatically create a reprex in the `_problems/` directory for each failing expectation. You can turn this behaviour off by setting `TESTTHAT_PROBLEMS=false` (#2263). * New `local_mocked_s3_method()`, `local_mocked_s4_method()`, and `local_mocked_r6_class()` allow you to mock S3 and S4 methods and R6 classes (#1892, #1916) * New `local_on_cran(TRUE)` allows you to simulate how your tests will run on CRAN (#2112). * `test_dir()`, `test_file()`, `test_package()`, `test_check()`, `test_local()`, `source_file()` gain a `shuffle` argument that uses `sample()` to randomly reorder the top-level expressions in each test file (#1942). This random reordering surfaces dependencies between tests and code outside of any test, as well as dependencies between tests. This helps you find and eliminate unintentional dependencies. diff --git a/R/extract.R b/R/extract.R new file mode 100644 index 000000000..e6d9430d4 --- /dev/null +++ b/R/extract.R @@ -0,0 +1,200 @@ +#' 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()`. +#' @param package If supplied, will be used to construct a test environment +#' for the extracted code. +#' @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(), + package = Sys.getenv("TESTTHAT_PKG") +) { + check_string(location) + check_string(package) + + pieces <- strsplit(location, ":")[[1]] + if (!length(pieces) %in% c(2, 3)) { + cli::cli_abort(c( + "Expected {.arg location} to be of the form FILE:LINE[:COLUMN]", + i = "Got {.arg location}: {.val {location}}" + )) + } + + test_path <- test_path(pieces[[1]]) + line <- as.integer(pieces[2]) + lines <- extract_test_(test_path, line, package) + + base::writeLines(lines, con = path) +} + +#' Simulate a test environment +#' +#' This function is designed to allow you to simulate testthat's testing +#' environment in an interactive session. To undo it's affect, you +#' will need to restart your R session. +#' +#' @keywords internal +#' @param package Name of installed package. +#' @param path Path to `tests/testthat`. +#' @export +#' @rdname topic-name +simulate_test_env <- function(package, path) { + check_string(package) + check_string(path) + + env <- test_env(package) + source_test_helpers(path, env = env) + source_test_setup(path, env = env) + + invisible(env) +} + +extract_test_ <- function( + test_path, + line, + package = Sys.getenv("TESTTHAT_PKG") +) { + source <- paste0("# Extracted from ", test_path, ":", line) + exprs <- parse_file(test_path) + + lines <- tryCatch( + extract_test_lines(exprs, line, package), + error = function(cnd) { + lines <- strsplit(conditionMessage(cnd), "\n")[[1]] + lines <- c("", "Failed to extract test: ", lines) + paste0("# ", lines) + } + ) + lines <- c(source, "", lines) + lines +} + +save_test <- function(srcref, dir, package = Sys.getenv("TESTTHAT_PKG")) { + if (env_var_is_false("TESTTHAT_PROBLEMS")) { + return() + } + + test_path <- utils::getSrcFilename(srcref, full.names = TRUE) + if (is.null(test_path) || !file.exists(test_path)) { + return() + } + line <- srcref[[3]] + extracted <- extract_test_(test_path, line, package) + + test_name <- tools::file_path_sans_ext(basename(test_path)) + dir_create(dir) + problems_path <- file.path(dir, paste0(test_name, "-", line, ".R")) + cat("Saving ", problems_path, "\n", sep = "") + writeLines(extracted, problems_path) + + invisible(problems_path) +} + +extract_test_lines <- function( + exprs, + line, + package = "", + 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 + lines <- c(header("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)) { + lines <- c( + header("prequel"), + srcref_to_character(srcrefs[is_prequel]), + "", + lines + ) + } + + if (package != "") { + lines <- c( + header("setup"), + "library(testthat)", + sprintf( + 'test_env <- simulate_test_env(package = "%s", path = "..")', + package + ), + "attach(test_env, warn.conflicts = FALSE)", + "", + lines + ) + } + lines +} + +# 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]]) +} + +header <- function(x) { + paste0("# ", x, " ", strrep("-", 80 - nchar(x) - 3)) +} diff --git a/R/reporter-check.R b/R/reporter-check.R index e70736ae0..1d5ac7d51 100644 --- a/R/reporter-check.R +++ b/R/reporter-check.R @@ -27,6 +27,7 @@ CheckReporter <- R6::R6Class( add_result = function(context, test, result) { if (expectation_broken(result)) { self$problems$push(result) + try(save_test(result$srcref, "_problems"), silent = TRUE) } else if (expectation_warning(result)) { self$warnings$push(result) } else if (expectation_skip(result)) { diff --git a/R/skip.R b/R/skip.R index 9b862acdb..b89f70cc1 100644 --- a/R/skip.R +++ b/R/skip.R @@ -323,3 +323,7 @@ on_cran <- function() { env_var_is_true <- function(x) { isTRUE(as.logical(Sys.getenv(x, "false"))) } + +env_var_is_false <- function(x) { + isFALSE(as.logical(Sys.getenv(x, "true"))) +} diff --git a/R/source.R b/R/source.R index 3c069d9f9..e80bbd413 100644 --- a/R/source.R +++ b/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 diff --git a/_pkgdown.yml b/_pkgdown.yml index e546e54aa..b508e6363 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -55,6 +55,7 @@ reference: - title: Test helpers contents: - is_testing + - extract_test - local_edition - local_reproducible_output - set_state_inspector diff --git a/man/extract_test.Rd b/man/extract_test.Rd new file mode 100644 index 000000000..cc574297e --- /dev/null +++ b/man/extract_test.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract.R +\name{extract_test} +\alias{extract_test} +\title{Extract a reprex from a failed expectation} +\usage{ +extract_test(location, path = stdout(), package = Sys.getenv("TESTTHAT_PKG")) +} +\arguments{ +\item{location}{A string giving the location in the form +\verb{FILE:LINE[:COLUMN]}.} + +\item{path}{Path to write the reprex to. Defaults to \code{stdout()}.} + +\item{package}{If supplied, will be used to construct a test environment +for the extracted code.} +} +\value{ +This function is called for its side effect of rendering a +reprex to \code{path}. This function will never error: if extraction +fails, the error message will be written to \code{path}. +} +\description{ +\code{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. +} +\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 +} diff --git a/man/topic-name.Rd b/man/topic-name.Rd new file mode 100644 index 000000000..ba6b594f7 --- /dev/null +++ b/man/topic-name.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract.R +\name{simulate_test_env} +\alias{simulate_test_env} +\title{Simulate a test environment} +\usage{ +simulate_test_env(package, path) +} +\description{ +This function is designed to allow you to simulate testthat's testing +environment in an interactive session. To undo it's affect, you +will need to restart your R session. +} +\keyword{internal} diff --git a/tests/testthat/_snaps/extract.md b/tests/testthat/_snaps/extract.md new file mode 100644 index 000000000..9faeeb457 --- /dev/null +++ b/tests/testthat/_snaps/extract.md @@ -0,0 +1,59 @@ +# can extract test from file + + Code + base::writeLines(readLines(out_path)) + Output + # Extracted from extract/simple.R:3 + + # setup ------------------------------------------------------------------------ + library(testthat) + test_env <- simulate_test_env(package = "testthat", path = "..") + attach(test_env, warn.conflicts = FALSE) + + # test ------------------------------------------------------------------------- + expect_true(TRUE) + +# can include test env setup + + Code + base::writeLines(extract_test_lines(exprs, 2, "test")) + Output + # setup ------------------------------------------------------------------------ + library(testthat) + test_env <- simulate_test_env(package = "test", path = "..") + attach(test_env, warn.conflicts = FALSE) + + # test ------------------------------------------------------------------------- + expect_true(TRUE) + +# 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 + # test ------------------------------------------------------------------------- + expect_true(TRUE) + diff --git a/tests/testthat/extract/simple.R b/tests/testthat/extract/simple.R new file mode 100644 index 000000000..61fba27ae --- /dev/null +++ b/tests/testthat/extract/simple.R @@ -0,0 +1,3 @@ +test_that('foo', { + expect_true(TRUE) +}) diff --git a/tests/testthat/test-extract.R b/tests/testthat/test-extract.R new file mode 100644 index 000000000..d779d3712 --- /dev/null +++ b/tests/testthat/test-extract.R @@ -0,0 +1,67 @@ +test_that("can extract test from file", { + exprs <- parse_file(test_path("extract/simple.R")) + + dir <- withr::local_tempdir() + out_path <- save_test(attr(exprs, "srcref")[[1]], dir = dir) + + expect_snapshot(base::writeLines(readLines(out_path))) +}) + +# extract_test_lines ----------------------------------------------------------- + +test_that("can include test env setup", { + # fmt: skip + exprs <- parse_text(" + test_that('foo', { + expect_true(TRUE) + }) + ") + expect_snapshot(base::writeLines(extract_test_lines(exprs, 2, "test"))) +}) + +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") +})