wip

.Rbuildignore

@@ -14,3 +14,4 @@
 ^srcjs$
 ^CONTRIBUTING.md$
 ^cran-comments.md$
+^.*\.o$

R/shiny.R

@@ -573,6 +573,8 @@ ShinySession <- R6Class(
               msg <- paste0("Error in output$", name, ": ", conditionMessage(cond), "\n")
               if (isTRUE(getOption("show.error.messages"))) {
                 cat(msg, file = stderr())
+                cat(file = stderr(), "Stack trace (innermost first):\n")
+                cat(file = stderr(), attr(cond, "stack.trace", exact = TRUE), "\n")
               }
               invisible(structure(msg, class = "try-error", condition = cond))
             }

R/utils.R

@@ -522,10 +522,73 @@ assignNestedList <- function(x = list(), idx, value) {
   x
 }
 
+# Formats sys.calls() into a nicer looking stack trace
+prettyStackTrace <- function(calls) {
+  paste0(collapse = "\n",
+    sapply(rev(calls), function(call) {
+      srcref <- attr(call, "srcref", exact = TRUE)
+      pretty <- paste0("    ", capture.output(print(call[[1]])))
+      if (!is.null(srcref)) {
+        srcfile <- attr(srcref, "srcfile", exact = TRUE)
+        if (!is.null(srcfile) && !is.null(srcfile$filename)) {
+          loc <- paste0(srcfile$filename, ":", srcref[[1]])
+          pretty <- paste0(pretty, " [", loc, "]")
+        }
+      }
+      pretty
+    })
+  )
+}
+
+captureStackTraces <- function(expr, truncate = 0) {
+  withCallingHandlers(expr,
+    error = function(e) {
+      if (is.null(attr(e, "stack.trace", exact = TRUE))) {
+        calls <- sys.calls()
+
+        # Offset calls vs. srcrefs by 1 to make them more intuitive.
+        # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
+        # the definition of foo().
+        srcrefs <- c(tail(getSrcRefs(calls), -1), list(NULL))
+        calls <- setSrcRefs(calls, srcrefs)
+
+        calls <- head(calls, -3)
+        if (!is.null(truncate) && !identical(truncate, FALSE)) {
+          # truncate means we'll drop parts of the stack trace that
+          # originate from withCallingHandlers and anything outside
+          # of that
+          cst <- as.symbol("captureStackTraces")
+          pos <- Position(function(x) {
+            identical(x[[1]], cst)
+          }, calls, right = TRUE, nomatch = NA)
+          if (!is.na(pos)) {
+            # The "+2" here is for captureStackTraces and withCallingHandlers
+            calls <- calls[(pos + 2 + truncate):length(calls)]
+          }
+        }
+        attr(e, "stack.trace") <- prettyStackTrace(calls)
+      }
+      stop(e)
+    }
+  )
+}
+
+getSrcRefs <- function(calls) {
+  lapply(calls, function(call) {
+    attr(call, "srcref", exact = TRUE)
+  })
+}
+
+setSrcRefs <- function(calls, srcrefs) {
+  mapply(function(call, srcref) {
+    structure(call, srcref = srcref)
+  }, calls, srcrefs)
+}
+
 # decide what to do in case of errors; it is customizable using the shiny.error
 # option (e.g. we can set options(shiny.error = recover))
 shinyCallingHandlers <- function(expr) {
-  withCallingHandlers(expr, error = function(e) {
+  withCallingHandlers(captureStackTraces(expr), error = function(e) {
     handle <- getOption('shiny.error')
     if (is.function(handle)) handle()
   })