Merge pull request #257 from posit-dev/feature/r-trace

Include R-level backtrace in failing `RFunction` calls

Author: lionel-

crates/ark/src/errors.rs

@@ -7,6 +7,7 @@
 
 use harp::object::RObject;
 use harp::r_symbol;
+use harp::session::r_format_traceback;
 use libr::R_GlobalEnv;
 use libr::R_NilValue;
 use libr::Rf_eval;
@@ -43,6 +44,11 @@ unsafe extern "C" fn ps_record_error(evalue: SEXP, traceback: SEXP) -> anyhow::R
     Ok(R_NilValue)
 }
 
+#[harp::register]
+unsafe extern "C" fn ps_format_traceback(calls: SEXP) -> anyhow::Result<SEXP> {
+    Ok(r_format_traceback(calls.into())?.sexp)
+}
+
 pub unsafe fn initialize() {
     // Must be called after the public Positron function environment is set up
     info!("Initializing global error handler");

crates/ark/src/interface.rs

@@ -184,17 +184,17 @@ pub fn start_r(
     libraries.initialize_post_setup_r();
 
     unsafe {
-        // Optionally run a user specified R startup script
-        if let Some(file) = &startup_file {
-            r_source(file).or_log_error(&format!("Failed to source startup file '{file}' due to"));
-        }
-
         // Register embedded routines
         r_register_routines();
 
         // Initialize harp (after routine registration)
         harp::initialize();
 
+        // Optionally run a user specified R startup script (after harp init)
+        if let Some(file) = &startup_file {
+            r_source(file).or_log_error(&format!("Failed to source startup file '{file}' due to"));
+        }
+
         // Initialize support functions (after routine registration)
         if let Err(err) = modules::initialize(false) {
             log::error!("Can't load R modules: {err:?}");

crates/ark/src/modules/positron/errors.R

@@ -137,99 +137,8 @@ handle_error_base <- function(cnd) {
 }
 
 #' @param traceback A list of calls.
-format_traceback <- function(traceback = list()) {
-    n <- length(traceback)
-
-    # TODO: This implementation prints the traceback in the same ordering
-    # as rlang, i.e. with call 1 on the stack being the first thing you
-    # see. `traceback()` prints in the reverse order, so users may want a
-    # way to reverse both our display ordering and rlang's (requiring a
-    # new `rlang::format()` argument).
-
-    # Collect source location, if there is any
-    srcrefs <- lapply(traceback, function(call) attr(call, "srcref"))
-    srcrefs <- vapply(srcrefs, src_loc, FUN.VALUE = character(1))
-    has_srcref <- nchar(srcrefs) != 0L
-    srcrefs[has_srcref] <- vec_paste0(" at ", srcrefs[has_srcref])
-
-    # Converts to a list of quoted calls to a list of deparsd calls.
-    # Respects global options `"traceback.max.lines"` and `"deparse.max.lines"`!
-    traceback <- .traceback(traceback)
-
-    # Prepend the stack number to each deparsed call, padding multiline calls as needed,
-    # and then collapse multiline calls into one line
-    prefixes <- vec_paste0(seq_len(n), ". ")
-    prefixes <- format(prefixes, justify = "right")
-
-    traceback <- mapply(prepend_prefix, traceback, prefixes, SIMPLIFY = FALSE)
-    traceback <- lapply(traceback, function(lines) paste0(lines, collapse = "\n"))
-    traceback <- as.character(traceback)
-
-    paste0(traceback, srcrefs)
-}
-
-prepend_prefix <- function(lines, prefix) {
-    n_lines <- length(lines)
-
-    if (n_lines == 0L) {
-        return(lines)
-    }
-
-    # First line gets the prefix
-    line <- lines[[1L]]
-    line <- vec_paste0(prefix, line)
-
-    # Other lines are padded with whitespace as needed
-    padding <- strrep(" ", times = nchar(prefix))
-
-    lines <- lines[-1L]
-    lines <- vec_paste0(padding, lines)
-
-    lines <- c(line, lines)
-
-    lines
-}
-
-src_loc <- function(srcref) {
-    # Adapted from `rlang:::src_loc()`
-    if (is.null(srcref)) {
-        return("")
-    }
-
-    srcfile <- attr(srcref, "srcfile")
-    if (is.null(srcfile)) {
-        return("")
-    }
-
-    # May be:
-    # - An actual file path
-    # - `""` for user defined functions in the console
-    # - `"<text>"` for `parse()`d functions
-    # We only try and display the source location for file paths
-    file <- srcfile$filename
-    if (identical(file, "") || identical(file, "<text>")) {
-        return("")
-    }
-
-    file_trimmed <- path_trim_prefix(file, 3L)
-
-    first_line <- srcref[[1L]]
-    first_column <- srcref[[5L]]
-
-    # TODO: We could generate file hyperlinks here like `rlang:::src_loc()`
-    paste0(file_trimmed, ":", first_line, ":", first_column)
-}
-
-path_trim_prefix <- function(path, n) {
-    # `rlang:::path_trim_prefix()`
-    split <- strsplit(path, "/")[[1]]
-    n_split <- length(split)
-
-    if (n_split <= n) {
-        path
-    } else {
-        paste(split[seq(n_split - n + 1, n_split)], collapse = "/")
-    }
+format_traceback <- function(calls = list()) {
+    .ps.Call("ps_format_traceback", calls)
 }
 
 handle_error_rlang <- function(cnd) {

crates/harp/src/error.rs

@@ -25,6 +25,7 @@ pub enum Error {
     EvaluationError {
         code: String,
         message: String,
+        trace: String,
     },
     UnsafeEvaluationError(String),
     UnexpectedLength(usize, usize),
@@ -89,8 +90,18 @@ impl fmt::Display for Error {
                 write!(f, "Error parsing {}: {}", code, message)
             },
 
-            Error::EvaluationError { code, message } => {
-                write!(f, "Error evaluating {}: {}", code, message)
+            Error::EvaluationError {
+                code,
+                message,
+                trace,
+            } => {
+                let mut msg = format!("Error evaluating {code}: {message}");
+
+                if !trace.is_empty() {
+                    msg = format!("{msg}\nR backtrace:\n{trace}");
+                }
+
+                write!(f, "{msg}")
             },
 
             Error::UnsafeEvaluationError(code) => {

crates/harp/src/eval.rs

@@ -59,6 +59,7 @@ pub fn r_parse_eval(code: &str, options: RParseEvalOptions) -> Result<RObject> {
                 return Err(Error::EvaluationError {
                     code: code.to_string(),
                     message: geterrmessage(),
+                    trace: String::from(""),
                 });
             }
         }

crates/harp/src/exec.rs

@@ -19,12 +19,14 @@ use crate::error::Result;
 use crate::interrupts::RInterruptsSuspendedScope;
 use crate::line_ending::convert_line_endings;
 use crate::line_ending::LineEnding;
+use crate::modules::HARP_ENV;
+use crate::object::r_list_get;
 use crate::object::RObject;
 use crate::polled_events::RPolledEventsSuspendedScope;
 use crate::protect::RProtect;
+use crate::r_null;
 use crate::r_string;
 use crate::r_symbol;
-use crate::utils::r_inherits;
 use crate::utils::r_stringify;
 use crate::vector::CharacterVector;
 use crate::vector::Vector;
@@ -83,38 +85,48 @@ impl RFunction {
     }
 
     pub fn call_in(&mut self, env: SEXP) -> Result<RObject> {
-        unsafe {
-            let call = self.call.build();
-
-            let mut protect = RProtect::new();
-
-            // now, wrap call in tryCatch, so that errors don't longjmp
-            let try_catch = protect.add(Rf_lang3(
-                r_symbol!("::"),
-                r_symbol!("base"),
-                r_symbol!("tryCatch"),
-            ));
-            let call = protect.add(Rf_lang4(
-                try_catch,
-                call.sexp,
-                r_symbol!("identity"),
-                r_symbol!("identity"),
-            ));
-            SET_TAG(call, R_NilValue);
-            SET_TAG(CDDR(call), r_symbol!("error"));
-            SET_TAG(CDDDR(call), r_symbol!("interrupt"));
-
-            let result = protect.add(Rf_eval(call, env));
-
-            if r_inherits(result, "error") {
-                let code = r_stringify(call, "\n")?;
-                let message = geterrmessage();
-                return Err(Error::EvaluationError { code, message });
-            }
+        let user_call = self.call.build();
+        r_safe_eval(user_call, env.into())
+    }
+}
 
-            return Ok(RObject::new(result));
+pub fn r_safe_eval(expr: RObject, env: RObject) -> crate::Result<RObject> {
+    // We could detect and cancel early exits from the r side, but we'd be at
+    // risk of very unlucky interrupts occurring between `rf_eval()` and our
+    // `on.exit()` handling. So stay on the safe side by wrapping in
+    // top-level-exec. This also insulates us from user handlers.
+    r_top_level_exec(|| unsafe {
+        let eval_call = RCall::new(r_symbol!("safe_evalq"))
+            .add(expr.sexp)
+            .add(env)
+            .build();
+
+        let result = RObject::new(Rf_eval(eval_call.sexp, HARP_ENV.unwrap()));
+
+        // Invariant of return value: List of length 2 [output, error].
+        // These are exclusive.
+        let out = r_list_get(result.sexp, 0);
+        let err = r_list_get(result.sexp, 1);
+
+        if err != r_null() {
+            let code = r_stringify(expr.sexp, "\n")?;
+
+            // Invariant of error slot: Character vector of length 2 [message, trace],
+            // with `trace` possibly an empty string.
+            let err = CharacterVector::new(err)?;
+
+            let message = err.get_value(0)?;
+            let trace = err.get_value(1)?;
+
+            return Err(Error::EvaluationError {
+                code,
+                message,
+                trace,
+            });
         }
-    }
+
+        Ok(RObject::new(out))
+    })?
 }
 
 impl From<&str> for RFunction {
@@ -177,6 +189,8 @@ pub fn geterrmessage() -> String {
     }
 }
 
+// TODO: Reimplement around `r_safe_eval()` to gain backtraces
+
 /// Wrappers around R_tryCatch()
 ///
 /// Takes a single closure that returns either a SEXP or `()`. If an R error is
@@ -320,25 +334,10 @@ pub unsafe fn r_try_catch<F, R>(fun: F) -> Result<RObject>
 where
     F: FnMut() -> R,
     RObject: From<R>,
-{
-    let out = r_try_catch_any(fun);
-    out.map(|x| RObject::from(x))
-}
-
-pub unsafe fn r_try_catch_any<F, R>(fun: F) -> Result<R>
-where
-    F: FnMut() -> R,
 {
     let vector = CharacterVector::create(["error"]);
-    r_try_catch_finally(fun, vector, || {})
-}
-
-pub unsafe fn r_try_catch_classes<F, R, S>(fun: F, classes: S) -> Result<R>
-where
-    F: FnMut() -> R,
-    S: Into<CharacterVector>,
-{
-    r_try_catch_finally(fun, classes, || {})
+    let out = r_try_catch_finally(fun, vector, || {});
+    out.map(|x| RObject::from(x))
 }
 
 /// Run closure inside top-level context
@@ -681,6 +680,22 @@ mod tests {
         }
     }
 
+    #[test]
+    fn test_basic_function_error() {
+        r_test! {
+            let result = RFunction::from("+")
+                .add(1)
+                .add("")
+                .call();
+
+            assert_match!(result, Err(err) => {
+                let msg = format!("{err}");
+                let re = regex::Regex::new("R backtrace:\n(.|\n)*1L [+] \"\"").unwrap();
+                assert!(re.is_match(&msg));
+            });
+        }
+    }
+
     #[test]
     fn test_utf8_strings() {
         r_test! {

crates/harp/src/lib.rs

@@ -62,6 +62,10 @@ pub type Result<T> = std::result::Result<T, error::Error>;
 // doesn't need synchronisation.
 pub static mut R_MAIN_THREAD_ID: Option<std::thread::ThreadId> = None;
 
+pub fn r_null() -> libr::SEXP {
+    unsafe { libr::R_NilValue }
+}
+
 #[macro_export]
 macro_rules! with_vector_impl {
     ($x:expr, $class:ident, $variable:ident, $($code:tt)*) => {{