From b000739c03c1e3427fc3e709a49a6626b95365cb Mon Sep 17 00:00:00 2001
From: Garrick Aden-Buie <garrick@adenbuie.com>
Date: Thu, 7 Oct 2021 17:18:23 -0400
Subject: [PATCH] Hand off parse error to error checker if one is available
 (#596)

* Hand off parse error to error checker if one is available

* `evaluate_exercise()` finds global exercise error checking

* Add tests

* exercise$error_check might be null in testing scenarios

* Errors in global setup code evaluation are now thrown as internal errors

also duplicated in log messages

* Better comments

* Add internal exercise result error helper and don't grade setup errors

- Internal error helper emits log messages via `message()` and an error exercise result with specificl language
- `render_exercise()` catches setup and user code errors but returns an internal error if the error comes from the setup chunk(s)
- The error condition of internal errors is returned under `$feedback$error`
- Pass the original user code error to the error checker, rather than the wrapped error we use to signal the issue

* A couple more code headings

* Internal errors throw warnings instead of messages

* Add news for #596

* Tweak NEWS.md

* v0.10.1.9016
---
 DESCRIPTION                    |   2 +-
 NEWS.md                        |   1 +
 R/evaluators.R                 |   9 +-
 R/exercise.R                   | 105 +++++++++++++++++--
 R/mock_exercise.R              |   3 +-
 tests/testthat/test-exercise.R | 179 +++++++++++++++++++++++++--------
 6 files changed, 243 insertions(+), 56 deletions(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index a43271956..c0646298a 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: learnr
 Title: Interactive Tutorials for R
-Version: 0.10.1.9015
+Version: 0.10.1.9016
 Authors@R:
     c(person(given = "Garrick",
              family = "Aden-Buie",
diff --git a/NEWS.md b/NEWS.md
index 450acad5b..697ac3b40 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -53,6 +53,7 @@ learnr (development version)
 * `options()` and environment variables are now reset after rendering exercises so changes made by user input or checking code cannot affect other exercises. ([#542](https://github.com/rstudio/learnr/pull/542))
 * Exercise checking is now conducted in the same temporary directory where exercises are evaluated. ([#544](https://github.com/rstudio/learnr/pull/544/))
 * User submissions for R code exercises are now checked for parsing errors prior to any other checks. If the submitted code is unparsable, a friendly error feedback message is returned and no further evaluation or checking is performed. ([#547](https://github.com/rstudio/learnr/pull/547))
+* Parse errors from user code that fails to parse can now be inspected by the error checker, but errors in exercise setup chunks cannot. Instead, global setup and setup chunk errors are raised as internal errors with a user-facing warning. In general, internal errors are now handled more consistently. ([#596](https://github.com/rstudio/learnr/pull/596))
 
 ## Bug fixes
 
diff --git a/R/evaluators.R b/R/evaluators.R
index 2c9d06222..2088f6b1c 100644
--- a/R/evaluators.R
+++ b/R/evaluators.R
@@ -313,12 +313,11 @@ internal_external_evaluator <- function(
           )
           do.call(exercise_result, result)
         }, error = function(e) {
-          warning(
-            "Unable to convert exercise result from external evaluator ",
-            "into a learnr exercise result.",
-            e$message
+          exercise_result_error_internal(
+            exercise = exercise,
+            error = e,
+            task_internal = "converting result from external evaluator into a learnr exercise result"
           )
-          exercise_result_error("An internal error occurred, please try again or contact the tutorial author.")
         })
       }
     )
diff --git a/R/exercise.R b/R/exercise.R
index 44276acce..64cdd52f0 100644
--- a/R/exercise.R
+++ b/R/exercise.R
@@ -90,9 +90,6 @@ setup_exercise_handler <- function(exercise_rx, session) {
       exercise$check <- NULL
       exercise$code_check <- NULL
       exercise$error_check <- NULL
-    } else {
-      # If there is no locally defined error check code, look for globally defined error check option
-      exercise$error_check <- exercise$error_check %||% exercise$options$exercise.error.check.code
     }
 
     # get timelimit option (either from chunk option or from global option)
@@ -321,6 +318,8 @@ standardize_exercise_code <- function(exercise) {
 evaluate_exercise <- function(
   exercise, envir, evaluate_global_setup = FALSE, data_dir = NULL
 ) {
+
+  # Exercise Prep and Standardization ---------------------------------------
   # Protect global options and environment vars from permanent modification
   local_restore_options_and_envvars()
 
@@ -332,6 +331,7 @@ evaluate_exercise <- function(
 
   # standardize exercise code to single string (code, *check, global_setup)
   exercise <- standardize_exercise_code(exercise)
+  exercise$envir <- envir
 
   i18n_set_language_option(exercise$tutorial$language)
 
@@ -341,8 +341,24 @@ evaluate_exercise <- function(
     return(exercise_result(html_output = " "))
   }
 
+  # Evaluate Global Setup ---------------------------------------------------
   if (evaluate_global_setup) {
-    eval(parse(text = exercise$global_setup), envir = envir)
+    res_global <-
+      tryCatch({
+        eval(parse(text = exercise$global_setup), envir = envir)
+        NULL
+      }, error = function(err) {
+        exercise_result_error_internal(
+          exercise,
+          err,
+          task_internal = "evaluating the global setup",
+          task_external = "setting up the tutorial"
+        )
+      })
+
+    if (is_exercise_result(res_global)) {
+      return(res_global)
+    }
   }
 
   # Check if user code has unfilled blanks ----------------------------------
@@ -403,17 +419,22 @@ evaluate_exercise <- function(
     render_exercise(exercise, envir),
     error = function(err_render) {
       error_feedback <- NULL
-      if (nzchar(exercise$error_check)) {
+      error_check_code <- exercise$error_check
+      if (!nzchar(error_check_code)) {
+        # If there is no locally defined error check code, look for globally defined error check option
+        error_check_code <- standardize_code(exercise$options$exercise.error.check.code)
+      }
+      if (nzchar(error_check_code)) {
         # Error check -------------------------------------------------------
         # Check the error thrown by the submitted code when there's error
         # checking: the exercise could be to throw an error!
         error_feedback <- try_checker(
           exercise,
-          check_code = exercise$error_check,
+          check_code = error_check_code,
           envir_result = err_render$envir_result,
           evaluate_result = err_render$evaluate_result,
           envir_prep = err_render$envir_prep,
-          last_value = err_render
+          last_value = err_render$last_value
         )
       }
       exercise_result_error(err_render$error_message, error_feedback$feedback)
@@ -604,6 +625,7 @@ render_exercise <- function(exercise, envir) {
 
   # First, Rmd to markdown (and exit early if any error)
   output_file <- tryCatch({
+    render_stage <- "setup"
     local({
       if (length(rmd_src_prep) > 0) {
         rmd_file_prep <- "exercise_prep.Rmd"
@@ -640,6 +662,7 @@ render_exercise <- function(exercise, envir) {
     # are much more difficult
     envir_result <- duplicate_env(envir_prep)
 
+    render_stage <- "user"
     with_masked_env_vars(
       # Now render user code for final result
       rmarkdown::render(
@@ -658,6 +681,19 @@ render_exercise <- function(exercise, envir) {
     if (grepl(pattern, msg, fixed = TRUE)) {
       return(exercise_result_timeout())
     }
+
+    if (render_stage == "setup") {
+      # errors in setup code should be returned as internal error results
+      return(
+        exercise_result_error_internal(
+          exercise = exercise,
+          error = e,
+          task_external = "setting up the exercise",
+          task_internal = "rendering exercise setup"
+        )
+      )
+    }
+
     rlang::abort(
       class = "learnr_render_exercise_error",
       envir_result = envir_result,
@@ -669,7 +705,7 @@ render_exercise <- function(exercise, envir) {
   })
 
   if (is_exercise_result(output_file)) {
-    # this only happens when the render result is a timeout error
+    # this only happens when the render result is a timeout error or setup error
     return(output_file)
   }
 
@@ -845,6 +881,29 @@ exercise_check_code_is_parsable <- function(exercise) {
     return(NULL)
   }
 
+  # apply the error checker (if explicitly provided) to the parse error
+  if (nzchar(exercise$error_check %||% "")) {
+    error_feedback <- try_checker(
+      exercise,
+      check_code = exercise[["error_check"]],
+      envir_result = exercise[["envir"]],
+      evaluate_result = error,
+      envir_prep = exercise[["envir"]],
+      last_value = error
+    )
+
+    if (is_exercise_result(error_feedback)) {
+      # we have feedback from the error checker so we return the original parse
+      # error with the feedback from the error checker
+      return(
+        exercise_result_error(
+          conditionMessage(error),
+          error_feedback[["feedback"]]
+        )
+      )
+    }
+  }
+
   exercise_result(
     list(
       message = HTML(
@@ -881,6 +940,36 @@ exercise_result_error <- function(error_message, feedback = NULL, timeout_exceed
   )
 }
 
+exercise_result_error_internal <- function(
+  exercise,
+  error,
+  task_external = "",
+  task_internal = task_external
+) {
+  task_external <- paste0(if (nzchar(task_external %||% "")) " while ", task_external)
+  task_internal <- paste0(if (nzchar(task_internal %||% "")) " while ", task_internal)
+
+  msg_internal <- sprintf(
+    "An error occurred%s for exercise '%s'",
+    task_internal,
+    exercise$label
+  )
+  rlang::warn(c(msg_internal, "x" = conditionMessage(error)))
+
+  exercise_result(
+    list(
+      correct = logical(),
+      type = "warning",
+      location = "replace",
+      message = sprintf(
+        "An internal error occurred%s. Please try again or contact the tutorial author.",
+        task_external
+      ),
+      error = error
+    )
+  )
+}
+
 exercise_result <- function(
   feedback = NULL,
   html_output = NULL,
diff --git a/R/mock_exercise.R b/R/mock_exercise.R
index 1dbef05bf..5bae74bec 100644
--- a/R/mock_exercise.R
+++ b/R/mock_exercise.R
@@ -42,7 +42,8 @@ mock_exercise <- function(
     fig.num = 0,
     exercise.df_print = exercise.df_print,
     exercise.warn_invisible = exercise.warn_invisible,
-    exercise.timelimit = exercise.timelimit
+    exercise.timelimit = exercise.timelimit,
+    exercise.error.check.code = exercise.error.check.code
   )
 
   has_exercise_chunk <- any(
diff --git a/tests/testthat/test-exercise.R b/tests/testthat/test-exercise.R
index d8fa274fe..f4996c07d 100644
--- a/tests/testthat/test-exercise.R
+++ b/tests/testthat/test-exercise.R
@@ -130,27 +130,6 @@ test_that("render_exercise() envir_prep and envir_result are distinct", {
   expect_equal(get("x", exercise_result$envir_result), 2)
 })
 
-test_that("render_exercise() returns identical envir_prep and envir_result if an error occurs in setup", {
-  exercise <- mock_exercise(
-    user_code = c("x <- 2"),
-    chunks = list(
-      mock_chunk("setup-1", c("x <- 1", "stop('boom')"))
-    ),
-    setup_label = "setup-1",
-    error_check = "unevaluated, triggers error_check in render_exercise()"
-  )
-
-  render_result <- withr::with_tempdir(
-    rlang::catch_cnd(
-      render_exercise(exercise, new.env()), "learnr_render_exercise_error"
-    )
-  )
-  expect_s3_class(render_result$last_value, "simpleError")
-  expect_equal(conditionMessage(render_result$last_value), "boom")
-  expect_identical(render_result$envir_prep, render_result$envir_result)
-  expect_equal(get("x", render_result$envir_prep), 1)
-})
-
 test_that("render_exercise() returns envir_result up to error", {
   exercise <- mock_exercise(
     user_code = c("y <- 2", "stop('boom')", "z <- 3"),
@@ -178,20 +157,96 @@ test_that("render_exercise() returns envir_result up to error", {
   expect_identical(get("y", exercise_result$envir_result), 2)
 })
 
-test_that("evaluate_exercise() with errors and no checker includes exercise result error", {
+test_that("evaluate_exercise() returns internal error if setup chunk throws an error", {
   exercise <- mock_exercise(
     user_code = "stop('user')",
     chunks = list(mock_chunk("setup-1", "stop('setup')")),
-    setup_label = "setup-1"
+    setup_label = "setup-1",
+    exercise.error.check.code = NULL
+  )
+  expect_warning(
+    exercise_result <- evaluate_exercise(exercise, new.env()),
+    "rendering exercise setup"
+  )
+  expect_match(exercise_result$feedback$message, "setting up the exercise")
+  expect_null(exercise_result$error_message)
+})
+
+test_that("evaluate_exercise() returns error in exercise result if no error checker", {
+  exercise <- mock_exercise(
+    user_code = "stop('user')",
+    error_check = NULL,
+    exercise.error.check.code = NULL
   )
+
   exercise_result <- evaluate_exercise(exercise, new.env())
-  expect_equal(exercise_result$error_message, "setup")
+  expect_equal(exercise_result$error_message, "user")
   expect_null(exercise_result$feedback)
+})
+
+test_that("evaluate_exercise() errors from setup chunks aren't checked by error checker", {
+  exercise <- mock_exercise(
+    user_code = "stop('user')",
+    chunks = list(mock_chunk("setup-1", "stop('setup')")),
+    setup_label = "setup-1",
+    error_check = I("'error_check'"),
+    exercise.error.check.code = I("'default_error_check'")
+  )
+  expect_warning(
+    exercise_result <- evaluate_exercise(exercise, new.env()),
+    "error occurred while rendering"
+  )
+  expect_match(exercise_result$feedback$message, "internal error occurred")
+  # internal error condition is passed around in $feedback$error
+  expect_s3_class(exercise_result$feedback$error, "simpleError")
+  expect_match(conditionMessage(exercise_result$feedback$error), "setup")
+})
+
+test_that("evaluate_exercise() errors from user code are checked by error_checker", {
+  exercise <- mock_exercise(
+    user_code = "stop('user')",
+    error_check = I("'error_check'"),
+    exercise.error.check.code = I("'default_error_check'")
+  )
 
-  exercise        <- mock_exercise(user_code = "stop('user')")
   exercise_result <- evaluate_exercise(exercise, new.env())
+  # check that error check function was called
+  expect_equal(exercise_result$feedback$checker_result, "error_check")
   expect_equal(exercise_result$error_message, "user")
-  expect_null(exercise_result$feedback)
+  expect_s3_class(exercise_result$feedback$checker_args$last_value, "simpleError")
+  expect_equal(
+    conditionMessage(exercise_result$feedback$checker_args$last_value),
+    exercise_result$error_message
+  )
+})
+
+test_that("evaluate_exercise() errors from user code are checked by default error checker as a fallback", {
+  exercise <- mock_exercise(
+    user_code = "stop('user')",
+    error_check = NULL,
+    exercise.error.check.code = I("'default_error_check'")
+  )
+
+  exercise_result <- evaluate_exercise(exercise, new.env())
+  # check that default error check function was called
+  expect_equal(exercise_result$feedback$checker_result, "default_error_check")
+  expect_equal(exercise_result$error_message, "user")
+  expect_s3_class(exercise_result$feedback$checker_args$last_value, "simpleError")
+  expect_equal(
+    conditionMessage(exercise_result$feedback$checker_args$last_value),
+    exercise_result$error_message
+  )
+})
+
+test_that("evaluate_exercise() returns an internal error for global setup chunk evaluation errors", {
+  ex <- mock_exercise(global_setup = "stop('global setup failure')")
+  expect_warning(
+    res <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE),
+    "evaluating the global setup"
+  )
+  expect_equal(conditionMessage(res$feedback$error), "global setup failure")
+  expect_match(res$feedback$message, "setting up the tutorial")
+  expect_s3_class(res$feedback$error, "simpleError")
 })
 
 test_that("render_exercise() cleans up exercise_prep files", {
@@ -219,25 +274,25 @@ test_that("render_exercise() cleans up exercise_prep files even when setup fails
   exercise <- mock_exercise(
     user_code = c("writeLines('nope', 'nope.txt')", "dir()"),
     # setup chunk throws an error
-    chunks = list(mock_chunk("ex-setup", c("dir_setup <- dir()", "stop('boom')"))),
+    chunks = list(mock_chunk("ex-setup", c("rlang::abort('setup-error', dir = dir())"))),
     # get file listing after error in setup chunk happens
     error_check = I("dir()")
   )
 
-  files <- expect_message(
-    withr::with_tempdir({
-      before <- dir()
-      e      <- rlang::catch_cnd(
-        render_exercise(exercise, new.env()), "learnr_render_exercise_error"
-      )
-
-      list(
-        before = before,
-        during = get("dir_setup", e$envir_prep),
-        after  = dir()
-      )
-    }),
-    "exercise_prep.Rmd"
+  files <- expect_warning(
+    expect_message(
+      withr::with_tempdir({
+        before <- dir()
+        env <- new.env()
+        res <- render_exercise(exercise, env)
+        list(
+          before = before,
+          during = res$feedback$error$dir,
+          after  = dir()
+        )
+      }),
+      "exercise_prep.Rmd"
+    )
   )
 
   # start with nothing
@@ -342,6 +397,19 @@ test_that("standardize_exercise_result() ensures top-level code is length-1 stri
   expect_equal(ex$global_setup, "def return_one():\n\treturn 1")
 })
 
+test_that("evaluate_exercise() handles default vs. explicit error check code", {
+  ex <- mock_exercise(
+    "stop('boom!')",
+    error_check = NULL,
+    exercise.error.check.code = I("'default_error_check_code'")
+  )
+
+  res <- evaluate_exercise(ex, new.env())
+  expect_equal(res$feedback$checker_result, "default_error_check_code")
+  expect_s3_class(res$feedback$checker_args$last_value, "simpleError")
+  expect_match(conditionMessage(res$feedback$checker_args$last_value), "boom")
+})
+
 # exercise_result() -------------------------------------------------------
 
 test_that("exercise_result() doesn't concatenate feedback and code output", {
@@ -938,6 +1006,35 @@ test_that("evaluate_exercise() returns a message if code is unparsable", {
   expect_match(result$error_message, "unexpected symbol")
 })
 
+test_that("evaluate_exercise() passes parse error to explicit exercise checker function", {
+  ex <- mock_exercise(
+    "_foo",
+    check = "check",
+    error_check = "error_check",
+    exercise.error.check.code = "default_error_check"
+  )
+
+  res <- evaluate_exercise(ex, new.env())
+  expect_equal(res$feedback$checker_args$check_code, "error_check")
+
+  ex$error_check <- NULL
+  res <- evaluate_exercise(ex, new.env())
+  expect_equal(res$feedback, exercise_check_code_is_parsable(ex)$feedback)
+})
+
+test_that("Errors with global setup code result in an internal error", {
+  ex <- mock_exercise(global_setup = "stop('boom')")
+  expect_warning(
+    res <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE),
+    "global setup"
+  )
+
+  expect_null(res$error_message)
+  expect_match(res$feedback$message, "internal error occurred while setting up the tutorial")
+  expect_s3_class(res$feedback$error, "simpleError")
+  expect_match(conditionMessage(res$feedback$error), "boom")
+})
+
 
 # Timelimit ---------------------------------------------------------------