Better srcrefs on failure/error (#1842)

Uses a better strategy based on containment of srcrefs — we first contain to the current testing file, and if possible the current `test_that()` block. That ensures you always get a srcref inside your tests and never to some helper function inside your package (which will be included in the backtrace if needed).

Author: hadley

NEWS.md

@@ -1,5 +1,11 @@
 # testthat (development version)
 
+* testthat uses an improved algorithm for finding the srcref associated with
+  an expectation/error/warning/skip. It now looks for the most recent call
+  that has known source and is found inside the `test_that()` call. This
+  generally gives more specific locations than the previous approach and
+  gives much better locations if an error occurs in an exit handler.
+
 * Helpers should no longer be run twice.
 
 * `test_file()` gains a `desc` argument which allows you to run a single 

R/expectation.R

@@ -249,16 +249,12 @@ single_letter_summary <- function(x) {
   )
 }
 
-expectation_location <- function(x) {
-  if (!inherits(x$srcref, "srcref")) {
-    "???"
-  } else {
-    srcfile <- attr(x$srcref, "srcfile")
-    filename <- srcfile$filename
-    if (identical(filename, "")) {
-      paste0("Line ", x$srcref[1])
-    } else {
-      cli::format_inline("{.file {filename}:{x$srcref[1]}:{x$srcref[2]}}")
-    }
+expectation_location <- function(x, prefix = "", suffix = "") {
+  srcref <- x$srcref
+  if (!inherits(srcref, "srcref")) {
+    return("")
   }
+
+  filename <- attr(srcref, "srcfile")$filename
+  cli::format_inline("{prefix}{.file {filename}:{srcref[1]}:{srcref[2]}}{suffix}")
 }

R/reporter-junit.R

@@ -111,8 +111,8 @@ JunitReporter <- R6::R6Class("JunitReporter",
       )
 
       first_line <- function(x) {
-        loc <- expectation_location(x)
-        paste0(strsplit(x$message, split = "\n")[[1]][1], " (", loc, ")")
+        loc <- expectation_location(x, " (", ")")
+        paste0(strsplit(x$message, split = "\n")[[1]][1], loc)
       }
 
       # add an extra XML child node if not a success

R/reporter-progress.R

@@ -519,8 +519,7 @@ issue_header <- function(x, pad = FALSE) {
    type <- strpad(type, 7)
   }
 
-  loc <- expectation_location(x)
-  paste0(type, " (", loc, "): ", x$test)
+  paste0(type, expectation_location(x, " (", ")"), ": ", x$test)
 }
 
 issue_summary <- function(x, rule = FALSE) {

R/reporter-stop.R

@@ -53,7 +53,7 @@ StopReporter <- R6::R6Class("StopReporter",
     },
     stop_if_needed = function() {
       if (self$stop_reporter && self$n_fail > 0) {
-        abort("Test failed")
+        abort("Test failed", call = NULL)
       }
     }
   )

R/reporter-summary.R

@@ -147,7 +147,7 @@ skip_summary <- function(x, label) {
   header <- paste0(label, ". ", x$test)
 
   paste0(
-    colourise(header, "skip"), " (", expectation_location(x), ") - ", x$message
+    colourise(header, "skip"), expectation_location(x, " (", ")"), " - ", x$message
   )
 }
 

R/source.R

@@ -38,7 +38,7 @@ source_file <- function(path,
     on.exit(setwd(old_dir), add = TRUE)
   }
 
-  withr::local_options(testthat_topenv = env)
+  withr::local_options(testthat_topenv = env, testthat_path = path)
   if (wrap) {
     invisible(test_code(
       test = NULL,

R/srcrefs.R

@@ -0,0 +1,85 @@
+find_expectation_srcref <- function(test_code_frame = NULL, top = caller_env()) {
+  # It's not possible to give useful srcrefs interactively so don't even try
+  path <- getOption("testthat_path")
+  if (is.null(path)) {
+    return(NULL)
+  }
+
+  # Scope our search to the current file loaded with source_file()
+  file_srcref <- srcref(srcfile(path), c(1, 1, 1e5, 1e5))
+
+  # Now attempt to narrow the scope to a call that leads to test_code(). That's
+  # usually test_that() but might be describe(), it(), or another wrapper.
+  testthat_srcref <- find_srcref(
+    top = test_code_frame,
+    container = file_srcref
+  )
+
+  # Now we can find the bottom-most call with a srcref that's inside that scope
+  call_srcref <- find_srcref(
+    top = top,
+    bottom = test_code_frame,
+    container = testthat_srcref %||% file_srcref
+  )
+
+  # If we can't find that we fall back to the test
+  call_srcref %||% testthat_srcref
+}
+
+find_srcref <- function(bottom = NULL,
+                        top = caller_env(),
+                        container = NULL) {
+
+  idx <- sys_index(bottom, top)
+  calls <- sys.calls()[rev(idx)]
+
+  for (call in calls) {
+    srcref <- attr(call, "srcref")
+
+    if (!is.null(srcref)) {
+      if (is.null(container) || srcref_inside(srcref, container)) {
+        return(srcref)
+      }
+    }
+  }
+
+  NULL
+}
+
+srcref_inside <- function(needle, haystack) {
+  stopifnot(inherits(needle, "srcref"), inherits(haystack, "srcref"))
+
+  needle_file <- attr(needle, "srcfile")$filename
+  haystack_file <- attr(haystack, "srcfile")$filename
+
+  if (!identical(needle_file, haystack_file)) {
+    return(FALSE)
+  }
+
+  sign_pair <- function(x, y) {
+    diff <- y - x
+    if (diff[1] == 0) sign(diff[2]) else sign(diff[1])
+  }
+
+  sign_pair(needle[1:2], haystack[1:2]) <= 0 &&
+    sign_pair(needle[3:4], haystack[3:4]) >= 0
+}
+
+sys_index <- function(bottom = NULL, top = caller_env()) {
+  frames <- sys.frames()
+  if (is.null(bottom)) {
+    bottom_idx <- 1
+  } else {
+    bottom_idx <- Position(function(env) identical(bottom, env), frames)
+    if (is.na(bottom_idx)) {
+      abort("Can't find `bottom` on stack")
+    }
+  }
+
+  top_idx <- Position(function(env) identical(top, env), frames)
+  if (is.na(top_idx)) {
+    abort("Can't find `top` on stack")
+  }
+
+  seq2(bottom_idx, top_idx)
+}

R/test-that.R

@@ -59,6 +59,7 @@ test_that <- function(desc, code) {
 # `$.Throwable` from the rJava package throws with unknown fields
 test_code <- function(test, code, env, default_reporter, skip_on_empty = TRUE) {
 
+  frame <- caller_env()
   reporter <- get_reporter() %||% default_reporter
 
   if (!is.null(test)) {
@@ -71,14 +72,12 @@ test_code <- function(test, code, env, default_reporter, skip_on_empty = TRUE) {
   # @param debug_end How many frames should be skipped to find the
   #   last relevant frame call. Only useful for the DebugReporter.
   register_expectation <- function(e, debug_end) {
-    # Find test environment on the stack
-    start <- eval_bare(quote(base::sys.nframe()), test_env) + 1L
-
-    srcref <- e[["srcref"]] %||% find_first_srcref(start)
+    srcref <- e[["srcref"]] %||% find_expectation_srcref(frame)
     e <- as.expectation(e, srcref = srcref)
 
     # Data for the DebugReporter
     if (debug_end >= 0) {
+      start <- eval_bare(quote(base::sys.nframe()), test_env) + 1L
       e$start_frame <- start
       e$end_frame <- sys.nframe() - debug_end - 1L
     }
@@ -89,7 +88,6 @@ test_code <- function(test, code, env, default_reporter, skip_on_empty = TRUE) {
     reporter$add_result(context = reporter$.context, test = test, result = e)
   }
 
-  frame <- sys.nframe()
   # 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
@@ -173,15 +171,7 @@ test_code <- function(test, code, env, default_reporter, skip_on_empty = TRUE) {
   handle_skip <- function(e) {
     handled <<- TRUE
 
-    if (inherits(e, "skip_empty")) {
-      # If we get here, `code` has already finished its evaluation.
-      # Find the srcref in the `test_that()` frame above.
-      e$srcref <- find_first_srcref(frame - 1)
-      debug_end <- -1
-    } else {
-      debug_end <- 2
-    }
-
+    debug_end <- if (inherits(e, "skip_empty")) -1 else 2
     register_expectation(e, debug_end)
     signalCondition(e)
   }

R/utils.R

@@ -4,21 +4,6 @@ magrittr::`%>%`
 
 null <- function(...) invisible()
 
-# Tools for finding srcrefs -----------------------------------------------
-
-find_first_srcref <- function(start) {
-  calls <- sys.calls()
-  calls <- calls[seq2(start, length(calls))]
-
-  for (call in calls) {
-    srcref <- attr(call, "srcref")
-    if (!is.null(srcref)) {
-      return(srcref)
-    }
-  }
-  NULL
-}
-
 escape_regex <- function(x) {
   chars <- c("*", ".", "?", "^", "+", "$", "|", "(", ")", "[", "]", "{", "}", "\\")
   gsub(paste0("([\\", paste0(collapse = "\\", chars), "])"), "\\\\\\1", x, perl = TRUE)