WIP

Author: hadley

R/source.R

@@ -21,6 +21,7 @@ source_file <- function(
 ) {
   stopifnot(file.exists(path))
   stopifnot(is.environment(env))
+  check_character(desc, allow_null = TRUE)
 
   lines <- brio::read_lines(path)
   srcfile <- srcfilecopy(
@@ -35,7 +36,7 @@ source_file <- function(
   con <- textConnection(lines, encoding = "UTF-8")
   on.exit(try(close(con), silent = TRUE), add = TRUE)
   exprs <- parse(con, n = -1, srcfile = srcfile, encoding = "UTF-8")
-  exprs <- filter_desc(exprs, desc, error_call = error_call)
+  exprs <- filter_subtests(exprs, desc, error_call = error_call)
 
   n <- length(exprs)
   if (n == 0L) {
@@ -69,63 +70,45 @@ source_file <- function(
   }
 }
 
-filter_desc <- function(exprs, desc = NULL, error_call = caller_env()) {
-  if (is.null(desc)) {
+filter_subtests <- function(exprs, descs, error_call = caller_env()) {
+  if (length(descs) == 0) {
     return(exprs)
   }
-  desc_levels <- if (is.list(desc)) {
-    desc
-  } else {
-    as.list(desc)
-  }
 
-  find_matching_expr <- function(exprs, queue) {
-    if (length(queue) == 0) {
-      exprs
-    } else {
-      found <- FALSE
-      include <- rep(FALSE, length(exprs))
-      desc <- queue[[1]]
-
-      for (i in seq_along(exprs)) {
-        expr <- exprs[[i]]
-
-        if (!is_call(expr, c("test_that", "describe", "it"), n = 2)) {
-          if (!found) {
-            include[[i]] <- TRUE
-          }
-        } else {
-          if (!is_string(expr[[2]])) {
-            next
-          }
-
-          test_desc <- as.character(expr[[2]])
-          if (test_desc != desc) {
-            next
-          }
-
-          if (found) {
-            abort(
-              "Found multiple tests with specified description",
-              call = error_call
-            )
-          }
-          include[[i]] <- TRUE
-          found <- TRUE
-          exprs[[i]][[3]] <- find_matching_expr(expr[[3]], queue[-1])
-        }
-      }
+  is_subtest <- unname(map_lgl(exprs, is_subtest))
 
-      if (!found) {
-        abort("Failed to find test with specified description", call = error_call)
-      }
+  subtest_idx <- which(is_subtest)
+  code_idx <- which(!is_subtest)
+  matching_idx <- keep(subtest_idx, \(idx) {
+    exprs[[idx]][[2]] == descs[[1]]
+  })
 
-      exprs[include]
-    }
+  if (length(matching_idx) == 0) {
+    cli::cli_abort(
+      "Failed to find test with specified description",
+      call = error_call
+    )
+  } else if (length(matching_idx) > 1) {
+    cli::cli_abort(
+      "Found multiple tests with specified description",
+      call = error_call
+    )
   }
-  find_matching_expr(exprs, desc_levels)
+
+  keep_idx <- intersect(seq_along(exprs), c(matching_idx, code_idx))
+  exprs[[matching_idx]] <- filter_subtests(
+    exprs[[matching_idx]],
+    descs[-1],
+    error_call = error_call
+  )
+  exprs[keep_idx]
 }
 
+is_subtest <- function(expr) {
+  is_call(expr, c("test_that", "describe", "it"), n = 2) && is_string(expr[[2]])
+}
+
+
 #' @rdname source_file
 #' @export
 source_dir <- function(

tests/testthat/_snaps/source.new.md

@@ -0,0 +1,18 @@
+# source_file wraps error
+
+    Code
+      source_file(test_path("reporters/error-setup.R"), wrap = FALSE)
+    Condition
+      Error:
+      ! In path: "reporters/error-setup.R"
+      Caused by error in `h()`:
+      ! !
+
+# errors if duplicate labels
+
+    Code
+      filter_desc(code, "baz")
+    Condition
+      Error in `filter_desc()`:
+      ! could not find function "filter_desc"
+

tests/testthat/test-source.R

@@ -85,9 +85,9 @@ test_that("can find only matching test", {
     describe("bar", {}),
     h()
   )
-  expect_equal(filter_desc(code, "foo"), code[c(1, 2)])
-  expect_equal(filter_desc(code, "bar"), code[c(1, 3, 4)])
-  expect_snapshot(filter_desc(code, "baz"), error = TRUE)
+  expect_equal(filter_subtests(code, "foo"), code[c(1, 2)])
+  expect_equal(filter_subtests(code, "bar"), code[c(1, 3, 4)])
+  expect_snapshot(filter_subtests(code, "baz"), error = TRUE)
 })
 
 test_that("preserve srcrefs", {
@@ -205,5 +205,8 @@ test_that("you can select deeply nested describe(...)", {
     })
   )
 
-  expect_equal(filter_desc(code, c("level 0", "level 1 A", "level 2 B", "level 3 C")), expected)
+  expect_equal(
+    filter_subtests(code, c("level 0", "level 1 A", "level 2 B", "level 3 C")),
+    expected
+  )
 })