Don't use a restart to handle stop_on_error = 2L

DESCRIPTION

@@ -25,11 +25,14 @@ BugReports: https://github.com/r-lib/evaluate/issues
 Depends:
     R (>= 3.6.0)
 Suggests:
+    callr,
     covr,
     ggplot2 (>= 3.3.6),
     lattice,
     methods,
+    pkgload,
     rlang,
+    knitr,
     testthat (>= 3.0.0),
     withr
 Config/Needs/website: tidyverse/tidytemplate

R/conditions.R

@@ -34,7 +34,8 @@ condition_handlers <- function(watcher, on_error, on_warning, on_message) {
       switch(on_error,
         continue = invokeRestart("eval_continue"),
         stop = invokeRestart("eval_stop"),
-        error = invokeRestart("eval_error", cnd)
+        # No need to invoke a restart as we want the error to be thrown in this case.
+        error = NULL
       )
     }
   )

R/evaluate.R

@@ -121,6 +121,11 @@ evaluate <- function(input,
   }
   local_inject_funs(envir)
 
+  if (is.null(getOption("rlang_trace_top_env"))) {
+    # If not already set, indicate the top environment to trim traceback
+    options(rlang_trace_top_env = envir)
+  }
+
   # Handlers for warnings, errors and messages
   user_handlers <- output_handler$calling_handlers
   evaluate_handlers <- condition_handlers(
@@ -151,8 +156,7 @@ evaluate <- function(input,
         handlers
       ),
       eval_continue = function() TRUE,
-      eval_stop = function() FALSE,
-      eval_error = function(cnd) {signalCondition(cnd); stop(cnd)}
+      eval_stop = function() FALSE
     )
     watcher$check_devices()
 

tests/testthat/_snaps/conditions.md

@@ -6,10 +6,10 @@
       Warning in `f()`:
       Hi!
 
-# all three starts of stop_on_error work as expected
+# all three values of stop_on_error work as expected
 
     Code
-      evaluate("stop(\"1\")\n2", stop_on_error = 2L)
+      ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L)
     Condition
       Error:
       ! 1

tests/testthat/_snaps/conditions/abort-error.txt

@@ -0,0 +1,10 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+ 4.       \-rlang::abort("!")
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/rmd-abort-error.md

@@ -0,0 +1,22 @@
+---
+title: document with error
+---
+
+
+``` r
+f <- function() g()
+g <- function() h()
+h <- function() rlang::abort("!")
+f()
+```
+
+```
+## Error in `h()`:
+## ! !
+## Backtrace:
+##     x
+##  1. \-evaluate (local) f()
+##  2.   \-evaluate (local) g()
+##  3.     \-evaluate (local) h()
+##  4.       \-rlang::abort("!")
+```

tests/testthat/_snaps/conditions/rmd-abort-error.txt

@@ -0,0 +1,12 @@
+
+
+processing file: ressources/with-abort-error.Rmd
+Error in `h()`:
+! !
+Backtrace:
+ 1. global f()
+ 2. global g()
+ 3. global h()
+
+Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-abort-error.Rmd)
+Execution halted

tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt

@@ -0,0 +1,12 @@
+
+
+processing file: ressources/with-stop-error-auto-entrace.Rmd
+Error in `h()`:
+! !
+Backtrace:
+ 1. global f()
+ 2. global g()
+ 3. global h()
+
+Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-stop-error-auto-entrace.Rmd)
+Execution halted

tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md

@@ -0,0 +1,27 @@
+---
+title: document with error
+---
+
+
+``` r
+rlang::global_entrace()
+options(rlang_backtrace_on_error_report = "full")
+```
+
+
+``` r
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```
+
+```
+## Error in `h()`:
+## ! !
+## Backtrace:
+##     x
+##  1. \-evaluate (local) f()
+##  2.   \-evaluate (local) g()
+##  3.     \-evaluate (local) h()
+```

tests/testthat/_snaps/conditions/rmd-stop-error.md

@@ -0,0 +1,15 @@
+---
+title: document with error
+---
+
+
+``` r
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```
+
+```
+## Error in h(): !
+```

tests/testthat/_snaps/conditions/stop-error-no-trace.txt

@@ -0,0 +1,4 @@
+Error in h() : !
+Calls: <Anonymous> ... withCallingHandlers -> withVisible -> eval -> eval -> f -> g -> h
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt

@@ -0,0 +1,9 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/stop-error-trace-trim.txt

@@ -0,0 +1,24 @@
+Error in `h()`:
+! !
+Backtrace:
+     x
+  1. +-evaluate::evaluate(...)
+  2. | +-base::withRestarts(...)
+  3. | | \-base (local) withRestartList(expr, restarts)
+  4. | |   +-base (local) withOneRestart(withRestartList(expr, restarts[-nr]), restarts[[nr]])
+  5. | |   | \-base (local) doWithOneRestart(return(expr), restart)
+  6. | |   \-base (local) withRestartList(expr, restarts[-nr])
+  7. | |     \-base (local) withOneRestart(expr, restarts[[1L]])
+  8. | |       \-base (local) doWithOneRestart(return(expr), restart)
+  9. | +-evaluate:::with_handlers(...)
+ 10. | | +-base::eval(call)
+ 11. | | | \-base::eval(call)
+ 12. | | \-base::withCallingHandlers(...)
+ 13. | +-base::withVisible(eval(expr, envir))
+ 14. | \-base::eval(expr, envir)
+ 15. |   \-base::eval(expr, envir)
+ 16. \-global f()
+ 17.   \-global g()
+ 18.     \-global h()
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/stop-error-trace-wch.txt

@@ -0,0 +1,9 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/helper.R

@@ -2,3 +2,20 @@ expect_output_types <- function(x, types) {
   output_types <- vapply(x, output_type, character(1))
   expect_equal(output_types, types)
 }
+
+quick_install <- function(package, lib, quiet = TRUE) {
+  opts <- c(
+    "--data-compress=none",
+    "--no-byte-compile",
+    "--no-data",
+    "--no-demo",
+    "--no-docs",
+    "--no-help",
+    "--no-html",
+    "--no-libs",
+    "--use-vanilla",
+    sprintf("--library=%s", lib),
+    package
+  )
+  invisible(callr::rcmd("INSTALL", opts, show = !quiet, fail_on_status = TRUE))
+}

tests/testthat/ressources/with-abort-error.R

@@ -0,0 +1,7 @@
+testthat::local_reproducible_output()
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() rlang::abort("!")
+  f()
+}, stop_on_error = 2L)

tests/testthat/ressources/with-abort-error.Rmd

@@ -0,0 +1,10 @@
+---
+title: document with error
+---
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() rlang::abort("!")
+f()
+```

tests/testthat/ressources/with-stop-error-auto-entrace.Rmd

@@ -0,0 +1,10 @@
+---
+title: document with error
+---
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```

tests/testthat/ressources/with-stop-error-no-trace.R

@@ -0,0 +1,7 @@
+testthat::local_reproducible_output()
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() stop("!")
+  f()
+}, stop_on_error = 2L)

tests/testthat/ressources/with-stop-error-sewed.Rmd

@@ -0,0 +1,15 @@
+---
+title: document with error
+---
+
+```{r}
+rlang::global_entrace()
+options(rlang_backtrace_on_error_report = "full")
+```
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```

tests/testthat/ressources/with-stop-error-trace-trim.R

@@ -0,0 +1,12 @@
+testthat::local_reproducible_output()
+handlers <- evaluate::new_output_handler(
+  calling_handlers = list(error = function(cnd) rlang::entrace(cnd))
+)
+library(evaluate)
+options(rlang_trace_top_env = rlang::pkg_env("evaluate"))
+evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() stop("!")
+  f()
+}, stop_on_error = 2L, output_handler = handlers)

tests/testthat/ressources/with-stop-error-trace.R

@@ -0,0 +1,10 @@
+testthat::local_reproducible_output()
+handlers <- evaluate::new_output_handler(
+  calling_handlers = list(error = function(cnd) rlang::entrace(cnd))
+)
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() stop("!")
+  f()
+}, stop_on_error = 2L, output_handler = handlers)

tests/testthat/ressources/with-stop-error-wch.R

@@ -0,0 +1,10 @@
+testthat::local_reproducible_output()
+withCallingHandlers(
+  error = function(cnd) rlang::entrace(cnd),
+  evaluate::evaluate(function() {
+    f <- function() g()
+    g <- function() h()
+    h <- function() stop("!")
+    f()
+  }, stop_on_error = 2L)
+)