Improve errors.R: hyperlinks + bits

- chain_error() takes a 'srcref' argument, for advanced use
  and wrappers.
- better printing of stack traces with operators, i.e. we do
  not add pkg:: to an operator.
- use 'procsrcrefs' column to avoid the more common 'srcref'
  name that testthat/rlang use, thinking that it is a proper
  source ref
- add hyperlinks to stack traces, for cli >= 3.4.1.9000

Author: gaborcsardi

R/errors.R

@@ -129,10 +129,16 @@
 #
 # * Major rewrite, use rlang compatible error objects. New API.
 #
-# ##3 3.0.1 -- 2022-06-17
+# ### 3.0.1 -- 2022-06-17
 #
 # * Remove the `rlang_error` and `rlang_trace` classes, because our new
 #   deparsed `call` column in the trace is not compatible with rlang.
+#
+# ### 3.0.2 -- 2022-08-01
+#
+# * Use a `procsrcref` column for processed source references.
+#   Otherwise testthat (and probably other rlang based packages), will
+#   pick up the `srcref` column, and they expect an `srcref` object there.
 
 err <- local({
 
@@ -303,15 +309,16 @@ err <- local({
   #' @param err Error object or message to use for the child error.
   #' @param call Call to use in the re-thrown error. See [throw()].
 
-  chain_error <- function(expr, err, call = sys.call(-1)) {
+  chain_error <- function(expr, err, call = sys.call(-1), srcref = NULL) {
     .hide_from_trace <- 1
     force(call)
-    srcref <- utils::getSrcref(sys.call())
+    srcref <- srcref %||% utils::getSrcref(sys.call())
     withCallingHandlers({
       expr
     }, error = function(e) {
       .hide_from_trace <- 0:1
       e$srcref <- srcref
+      e$procsrcref <- NULL
       if (!inherits(err, "condition")) {
         err <- new_error(err, call. = call)
       }
@@ -342,6 +349,7 @@ err <- local({
       error = function(e) {
         .hide_from_trace <- 0:1
         e$srcref <- srcref
+        e$procsrcref <- NULL
         e$call <- call
         name <- native_name(.NAME)
         err <- new_error("Native call to `", name, "` failed", call. = call1)
@@ -376,6 +384,7 @@ err <- local({
       error = function(e) {
         .hide_from_trace <- 0:1
         e$srcref <- srcref
+        e$procsrcref <- NULL
         e$call <- call
         name <- native_name(.NAME)
         err <- new_error("Native call to `", name, "` failed", call. = call1)
@@ -409,7 +418,11 @@ err <- local({
     namespaces <- unlist(lapply(
       seq_along(frames),
       function(i) {
-        env_label(topenvx(environment(sys.function(i))))
+        if (is_operator(calls[[i]])) {
+          "o"
+        } else {
+          env_label(topenvx(environment(sys.function(i))))
+        }
       }
     ))
     pids <- rep(cond$`_pid` %||% Sys.getpid(), length(calls))
@@ -443,6 +456,7 @@ err <- local({
     pcs <- lapply(calls, function(c) process_call(list(call = c)))
     calls <- lapply(pcs, "[[", "call")
     srcrefs <- I(lapply(pcs, "[[", "srcref"))
+    procsrcrefs <- I(lapply(pcs, "[[", "procsrcref"))
 
     cond$trace <- new_trace(
       calls,
@@ -451,12 +465,18 @@ err <- local({
       namespaces = namespaces,
       scopes = scopes,
       srcrefs = srcrefs,
+      procsrcrefs = procsrcrefs,
       pids
     )
 
     cond
   }
 
+  is_operator <- function(cl) {
+    is.call(cl) && length(cl) >= 1 && is.symbol(cl[[1]]) &&
+      grepl("^[^.a-zA-Z]", as.character(cl[[1]]))
+  }
+
   mark_invisible_frames <- function(funs, frames) {
     visibles <- rep(TRUE, length(frames))
     hide <- lapply(frames, "[[", ".hide_from_trace")
@@ -527,14 +547,15 @@ err <- local({
     topenv(x, matchThisEnv = err_env)
   }
 
-  new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, pids) {
+  new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, procsrcrefs, pids) {
     trace <- data.frame(
       stringsAsFactors = FALSE,
       parent = parents,
       visible = visibles,
       namespace = namespaces,
       scope = scopes,
       srcref = srcrefs,
+      procsrcref = procsrcrefs,
       pid = pids
     )
     trace$call <- calls
@@ -757,7 +778,7 @@ err <- local({
   format_header_line_cli <- function(x, prefix = NULL) {
     p_error <- format_error_heading_cli(x, prefix)
     p_call <- format_call_cli(x$call)
-    p_srcref <- format_srcref_cli(conditionCall(x), x$srcref)
+    p_srcref <- format_srcref_cli(conditionCall(x), x$procsrcref %||% x$srcref)
     paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
   }
 
@@ -829,10 +850,10 @@ err <- local({
       rep(TRUE, nrow(x))
     }
 
-    srcref <- if ("srcref" %in% names(x)) {
+    srcref <- if ("srcref" %in% names(x) || "procsrcref" %in% names(x)) {
       vapply(
         seq_len(nrow(x)),
-        function(i) format_srcref_cli(x$call[[i]], x$srcref[[i]]),
+        function(i) format_srcref_cli(x$call[[i]], x$procsrcref[[i]] %||% x$srcref[[i]]),
         character(1)
       )
     } else {
@@ -843,7 +864,9 @@ err <- local({
       cli::col_silver(format(x$num), ". "),
       ifelse (visible, "", "| "),
       scope,
-      vapply(x$call, format_trace_call_cli, character(1)),
+      vapply(seq_along(x$call), function(i) {
+        format_trace_call_cli(x$call[[i]], x$namespace[[i]])
+      }, character(1)),
       srcref
     )
 
@@ -855,10 +878,16 @@ err <- local({
     lines
   }
 
-  format_trace_call_cli <- function(call) {
+  format_trace_call_cli <- function(call, ns = "") {
+    envir <- tryCatch(asNamespace(ns), error = function(e) .GlobalEnv)
     cl <- trimws(format(call))
     if (length(cl) > 1) { cl <- paste0(cl[1], " ", cli::symbol$ellipsis) }
-    fmc <- cli::code_highlight(cl)[1]
+    # Older cli does not have 'envir'.
+    if ("envir" %in% names(formals(cli::code_highlight))) {
+      fmc <- cli::code_highlight(cl, envir = envir)[1]
+    } else {
+      fmc <- cli::code_highlight(cl)[1]
+    }
     cli::ansi_strtrim(fmc, cli::console_width() - 5)
   }
 
@@ -897,10 +926,10 @@ err <- local({
       rep(TRUE, nrow(x))
     }
 
-    srcref <- if ("srcref" %in% names(x)) {
+    srcref <- if ("srcref" %in% names(x) || "procsrfref" %in% names(x)) {
       vapply(
         seq_len(nrow(x)),
-        function(i) format_srcref_plain(x$call[[i]], x$srcref[[i]]),
+        function(i) format_srcref_plain(x$call[[i]], x$procsrcref[[i]] %||% x$srcref[[i]]),
         character(1)
       )
     } else {
@@ -925,7 +954,7 @@ err <- local({
   format_header_line_plain <- function(x, prefix = NULL) {
     p_error <- format_error_heading_plain(x, prefix)
     p_call <- format_call_plain(x$call)
-    p_srcref <- format_srcref_plain(conditionCall(x), x$srcref)
+    p_srcref <- format_srcref_plain(conditionCall(x), x$procsrcref %||% x$srcref)
     paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
   }
 
@@ -990,15 +1019,16 @@ err <- local({
   }
 
   process_call <- function(cond) {
-    cond[c("call", "srcref")] <- list(
+    cond[c("call", "srcref", "procsrcref")] <- list(
       call = if (is.null(cond$call)) {
         NULL
       } else if (is.character(cond$call)) {
         cond$call
       } else {
         deparse(cond$call, nlines = 2)
       },
-      srcref = get_srcref(cond$call, cond$srcref)
+      srcref = NULL,
+      procsrcref = get_srcref(cond$call, cond$procsrcref %||% cond$srcref)
     )
     cond
   }