1 2# # Standalone file for better error handling ---------------------------- 3# 4# If can allow package dependencies, then you are probably better off 5# using rlang's functions for errors. 6# 7# The canonical location of this file is in the processx package: 8# https://github.com/r-lib/processx/master/R/errors.R 9# 10# ## Features 11# 12# - Throw conditions and errors with the same API. 13# - Automatically captures the right calls and adds them to the conditions. 14# - Sets `.Last.error`, so you can easily inspect the errors, even if they 15# were not caught. 16# - It only sets `.Last.error` for the errors that are not caught. 17# - Hierarchical errors, to allow higher level error messages, that are 18# more meaningful for the users, while also keeping the lower level 19# details in the error object. (So in `.Last.error` as well.) 20# - `.Last.error` always includes a stack trace. (The stack trace is 21# common for the whole error hierarchy.) The trace is accessible within 22# the error, e.g. `.Last.error$trace`. The trace of the last error is 23# also at `.Last.error.trace`. 24# - Can merge errors and traces across multiple processes. 25# - Pretty-print errors and traces, if the cli package is loaded. 26# - Automatically hides uninformative parts of the stack trace when 27# printing. 28# 29# ## API 30# 31# ``` 32# new_cond(..., call. = TRUE, domain = NULL) 33# new_error(..., call. = TRUE, domain = NULL) 34# throw(cond, parent = NULL) 35# catch_rethrow(expr, ...) 36# rethrow(expr, cond) 37# rethrow_call(.NAME, ...) 38# add_trace_back(cond) 39# ``` 40# 41# ## Roadmap: 42# - better printing of anonymous function in the trace 43# 44# ## NEWS: 45# 46# ### 1.0.0 -- 2019-06-18 47# 48# * First release. 49# 50# ### 1.0.1 -- 2019-06-20 51# 52# * Add `rlib_error_always_trace` option to always add a trace 53# 54# ### 1.0.2 -- 2019-06-27 55# 56# * Internal change: change topenv of the functions to baseenv() 57# 58# ### 1.1.0 -- 2019-10-26 59# 60# * Register print methods via onload_hook() function, call from .onLoad() 61# * Print the error manually, and the trace in non-interactive sessions 62# 63# ### 1.1.1 -- 2019-11-10 64# 65# * Only use `trace` in parent errors if they are `rlib_error`s. 66# Because e.g. `rlang_error`s also have a trace, with a slightly 67# different format. 68# 69# ### 1.2.0 -- 2019-11-13 70# 71# * Fix the trace if a non-thrown error is re-thrown. 72# * Provide print_this() and print_parents() to make it easier to define 73# custom print methods. 74# * Fix annotating our throw() methods with the incorrect `base::`. 75# 76# ### 1.2.1 -- 2020-01-30 77# 78# * Update wording of error printout to be less intimidating, avoid jargon 79# * Use default printing in interactive mode, so RStudio can detect the 80# error and highlight it. 81# * Add the rethrow_call_with_cleanup function, to work with embedded 82# cleancall. 83# 84# ### 1.2.2 -- 2020-11-19 85# 86# * Add the `call` argument to `catch_rethrow()` and `rethrow()`, to be 87# able to omit calls. 88# 89# ### 1.2.3 -- 2021-03-06 90# 91# * Use cli instead of crayon 92# 93# ### 1.2.4 -- 2021-04-01 94# 95# * Allow omitting the call with call. = FALSE in `new_cond()`, etc. 96# 97# ### 1.3.0 -- 2021-04-19 98# 99# * Avoid embedding calls in trace with embed = FALSE. 100# 101# ### 2.0.0 -- 2021-04-19 102# 103# * Versioned classes and print methods 104 105err <- local({ 106 107 # -- condition constructors ------------------------------------------- 108 109 #' Create a new condition 110 #' 111 #' @noRd 112 #' @param ... Parts of the error message, they will be converted to 113 #' character and then concatenated, like in [stop()]. 114 #' @param call. A call object to include in the condition, or `TRUE` 115 #' or `NULL`, meaning that [throw()] should add a call object 116 #' automatically. If `FALSE`, then no call is added. 117 #' @param domain Translation domain, see [stop()]. 118 #' @return Condition object. Currently a list, but you should not rely 119 #' on that. 120 121 new_cond <- function(..., call. = TRUE, domain = NULL) { 122 message <- .makeMessage(..., domain = domain) 123 structure( 124 list(message = message, call = call.), 125 class = c("condition")) 126 } 127 128 #' Create a new error condition 129 #' 130 #' It also adds the `rlib_error` class. 131 #' 132 #' @noRd 133 #' @param ... Passed to [new_cond()]. 134 #' @param call. Passed to [new_cond()]. 135 #' @param domain Passed to [new_cond()]. 136 #' @return Error condition object with classes `rlib_error`, `error` 137 #' and `condition`. 138 139 new_error <- function(..., call. = TRUE, domain = NULL) { 140 cond <- new_cond(..., call. = call., domain = domain) 141 class(cond) <- c("rlib_error_2_0", "rlib_error", "error", "condition") 142 cond 143 } 144 145 # -- throwing conditions ---------------------------------------------- 146 147 #' Throw a condition 148 #' 149 #' If the condition is an error, it will also call [stop()], after 150 #' signalling the condition first. This means that if the condition is 151 #' caught by an exiting handler, then [stop()] is not called. 152 #' 153 #' @noRd 154 #' @param cond Condition object to throw. If it is an error condition, 155 #' then it calls [stop()]. 156 #' @param parent Parent condition. Use this within [rethrow()] and 157 #' [catch_rethrow()]. 158 159 throw <- function(cond, parent = NULL) { 160 if (!inherits(cond, "condition")) { 161 throw(new_error("You can only throw conditions")) 162 } 163 if (!is.null(parent) && !inherits(parent, "condition")) { 164 throw(new_error("Parent condition must be a condition object")) 165 } 166 167 if (isTRUE(cond$call)) { 168 cond$call <- sys.call(-1) %||% sys.call() 169 } else if (identical(cond$call, FALSE)) { 170 cond$call <- NULL 171 } 172 173 # Eventually the nframe numbers will help us print a better trace 174 # When a child condition is created, the child will use the parent 175 # error object to make note of its own nframe. Here we copy that back 176 # to the parent. 177 if (is.null(cond$`_nframe`)) cond$`_nframe` <- sys.nframe() 178 if (!is.null(parent)) { 179 cond$parent <- parent 180 cond$call <- cond$parent$`_childcall` 181 cond$`_nframe` <- cond$parent$`_childframe` 182 cond$`_ignore` <- cond$parent$`_childignore` 183 } 184 185 # We can set an option to always add the trace to the thrown 186 # conditions. This is useful for example in context that always catch 187 # errors, e.g. in testthat tests or knitr. This options is usually not 188 # set and we signal the condition here 189 always_trace <- isTRUE(getOption("rlib_error_always_trace")) 190 if (!always_trace) signalCondition(cond) 191 192 # If this is not an error, then we'll just return here. This allows 193 # throwing interrupt conditions for example, with the same UI. 194 if (! inherits(cond, "error")) return(invisible()) 195 196 if (is.null(cond$`_pid`)) cond$`_pid` <- Sys.getpid() 197 if (is.null(cond$`_timestamp`)) cond$`_timestamp` <- Sys.time() 198 199 # If we get here that means that the condition was not caught by 200 # an exiting handler. That means that we need to create a trace. 201 # If there is a hand-constructed trace already in the error object, 202 # then we'll just leave it there. 203 if (is.null(cond$trace)) cond <- add_trace_back(cond) 204 205 # Set up environment to store .Last.error, it will be just before 206 # baseenv(), so it is almost as if it was in baseenv() itself, like 207 # .Last.value. We save the print methos here as well, and then they 208 # will be found automatically. 209 if (! "org:r-lib" %in% search()) { 210 do.call("attach", list(new.env(), pos = length(search()), 211 name = "org:r-lib")) 212 } 213 env <- as.environment("org:r-lib") 214 env$.Last.error <- cond 215 env$.Last.error.trace <- cond$trace 216 217 # If we always wanted a trace, then we signal the condition here 218 if (always_trace) signalCondition(cond) 219 220 # Top-level handler, this is intended for testing only for now, 221 # and its design might change. 222 if (!is.null(th <- getOption("rlib_error_handler")) && 223 is.function(th)) { 224 th(cond) 225 226 } else { 227 228 if (is_interactive()) { 229 # In interactive mode, we print the error message through 230 # conditionMessage() and also add a note about .Last.error.trace. 231 # R will potentially truncate the error message, so we make sure 232 # that the note is shown. Ideally we would print the error 233 # ourselves, but then RStudio would not highlight it. 234 max_msg_len <- as.integer(getOption("warning.length")) 235 if (is.na(max_msg_len)) max_msg_len <- 1000 236 msg <- conditionMessage(cond) 237 adv <- style_advice( 238 "\nType .Last.error.trace to see where the error occurred" 239 ) 240 dots <- "\033[0m\n[...]" 241 if (bytes(msg) + bytes(adv) + bytes(dots) + 5L> max_msg_len) { 242 msg <- paste0( 243 substr(msg, 1, max_msg_len - bytes(dots) - bytes(adv) - 5L), 244 dots 245 ) 246 } 247 cond$message <- paste0(msg, adv) 248 249 } else { 250 # In non-interactive mode, we print the error + the traceback 251 # manually, to make sure that it won't be truncated by R's error 252 # message length limit. 253 cat("\n", file = stderr()) 254 cat(style_error(gettext("Error: ")), file = stderr()) 255 out <- capture_output(print(cond)) 256 cat(out, file = stderr(), sep = "\n") 257 out <- capture_output(print(cond$trace)) 258 cat(out, file = stderr(), sep = "\n") 259 260 # Turn off the regular error printing to avoid printing 261 # the error twice. 262 opts <- options(show.error.messages = FALSE) 263 on.exit(options(opts), add = TRUE) 264 } 265 266 # Dropping the classes and adding "duplicate_condition" is a workaround 267 # for the case when we have non-exiting handlers on throw()-n 268 # conditions. These would get the condition twice, because stop() 269 # will also signal it. If we drop the classes, then only handlers 270 # on "condition" objects (i.e. all conditions) get duplicate signals. 271 # This is probably quite rare, but for this rare case they can also 272 # recognize the duplicates from the "duplicate_condition" extra class. 273 class(cond) <- c("duplicate_condition", "condition") 274 275 stop(cond) 276 } 277 } 278 279 # -- rethrowing conditions -------------------------------------------- 280 281 #' Catch and re-throw conditions 282 #' 283 #' See [rethrow()] for a simpler interface that handles `error` 284 #' conditions automatically. 285 #' 286 #' @noRd 287 #' @param expr Expression to evaluate. 288 #' @param ... Condition handler specification, the same way as in 289 #' [withCallingHandlers()]. You are supposed to call [throw()] from 290 #' the error handler, with a new error object, setting the original 291 #' error object as parent. See examples below. 292 #' @param call Logical flag, whether to add the call to 293 #' `catch_rethrow()` to the error. 294 #' @examples 295 #' f <- function() { 296 #' ... 297 #' err$catch_rethrow( 298 #' ... code that potentially errors ..., 299 #' error = function(e) { 300 #' throw(new_error("This will be the child error"), parent = e) 301 #' } 302 #' ) 303 #' } 304 305 catch_rethrow <- function(expr, ..., call = TRUE) { 306 realcall <- if (isTRUE(call)) sys.call(-1) %||% sys.call() 307 realframe <- sys.nframe() 308 parent <- parent.frame() 309 310 cl <- match.call() 311 cl[[1]] <- quote(withCallingHandlers) 312 handlers <- list(...) 313 for (h in names(handlers)) { 314 cl[[h]] <- function(e) { 315 # This will be NULL if the error is not throw()-n 316 if (is.null(e$`_nframe`)) e$`_nframe` <- length(sys.calls()) 317 e$`_childcall` <- realcall 318 e$`_childframe` <- realframe 319 # We drop after realframe, until the first withCallingHandlers 320 wch <- find_call(sys.calls(), quote(withCallingHandlers)) 321 if (!is.na(wch)) e$`_childignore` <- list(c(realframe + 1L, wch)) 322 handlers[[h]](e) 323 } 324 } 325 eval(cl, envir = parent) 326 } 327 328 find_call <- function(calls, call) { 329 which(vapply( 330 calls, function(x) length(x) >= 1 && identical(x[[1]], call), 331 logical(1)))[1] 332 } 333 334 #' Catch and re-throw conditions 335 #' 336 #' `rethrow()` is similar to [catch_rethrow()], but it has a simpler 337 #' interface. It catches conditions with class `error`, and re-throws 338 #' `cond` instead, using the original condition as the parent. 339 #' 340 #' @noRd 341 #' @param expr Expression to evaluate. 342 #' @param ... Condition handler specification, the same way as in 343 #' [withCallingHandlers()]. 344 #' @param call Logical flag, whether to add the call to 345 #' `rethrow()` to the error. 346 347 rethrow <- function(expr, cond, call = TRUE) { 348 realcall <- if (isTRUE(call)) sys.call(-1) %||% sys.call() 349 realframe <- sys.nframe() 350 withCallingHandlers( 351 expr, 352 error = function(e) { 353 # This will be NULL if the error is not throw()-n 354 if (is.null(e$`_nframe`)) e$`_nframe` <- length(sys.calls()) 355 e$`_childcall` <- realcall 356 e$`_childframe` <- realframe 357 # We just ignore the withCallingHandlers call, and the tail 358 e$`_childignore` <- list( 359 c(realframe + 1L, realframe + 1L), 360 c(e$`_nframe` + 1L, sys.nframe() + 1L)) 361 throw(cond, parent = e) 362 } 363 ) 364 } 365 366 #' Version of .Call that throw()s errors 367 #' 368 #' It re-throws error from interpreted code. If the error had class 369 #' `simpleError`, like all errors, thrown via `error()` in C do, it also 370 #' adds the `c_error` class. 371 #' 372 #' @noRd 373 #' @param .NAME Compiled function to call, see [.Call()]. 374 #' @param ... Function arguments, see [.Call()]. 375 #' @return Result of the call. 376 377 rethrow_call <- function(.NAME, ...) { 378 call <- sys.call() 379 nframe <- sys.nframe() 380 withCallingHandlers( 381 # do.call to work around an R CMD check issue 382 do.call(".Call", list(.NAME, ...)), 383 error = function(e) { 384 e$`_nframe` <- nframe 385 e$call <- call 386 if (inherits(e, "simpleError")) { 387 class(e) <- c("c_error", "rlib_error_2_0", "rlib_error", "error", "condition") 388 } 389 e$`_ignore` <- list(c(nframe + 1L, sys.nframe() + 1L)) 390 throw(e) 391 } 392 ) 393 } 394 395 package_env <- topenv() 396 397 #' Version of rethrow_call that supports cleancall 398 #' 399 #' This function is the same as [rethrow_call()], except that it 400 #' uses cleancall's [.Call()] wrapper, to enable resource cleanup. 401 #' See https://github.com/r-lib/cleancall#readme for more about 402 #' resource cleanup. 403 #' 404 #' @noRd 405 #' @param .NAME Compiled function to call, see [.Call()]. 406 #' @param ... Function arguments, see [.Call()]. 407 #' @return Result of the call. 408 409 rethrow_call_with_cleanup <- function(.NAME, ...) { 410 call <- sys.call() 411 nframe <- sys.nframe() 412 withCallingHandlers( 413 package_env$call_with_cleanup(.NAME, ...), 414 error = function(e) { 415 e$`_nframe` <- nframe 416 e$call <- call 417 if (inherits(e, "simpleError")) { 418 class(e) <- c("c_error", "rlib_error_2_0", "rlib_error", "error", "condition") 419 } 420 e$`_ignore` <- list(c(nframe + 1L, sys.nframe() + 1L)) 421 throw(e) 422 } 423 ) 424 } 425 426 # -- create traceback ------------------------------------------------- 427 428 #' Create a traceback 429 #' 430 #' [throw()] calls this function automatically if an error is not caught, 431 #' so there is currently not much use to call it directly. 432 #' 433 #' @param cond Condition to add the trace to 434 #' @param embed Whether to embed calls into the condition. 435 #' 436 #' @return A condition object, with the trace added. 437 438 add_trace_back <- function( 439 cond, 440 embed = getOption("rlib_error_embed_calls", FALSE)) { 441 442 idx <- seq_len(sys.parent(1L)) 443 frames <- sys.frames()[idx] 444 445 parents <- sys.parents()[idx] 446 calls <- as.list(sys.calls()[idx]) 447 envs <- lapply(frames, env_label) 448 topenvs <- lapply( 449 seq_along(frames), 450 function(i) env_label(topenvx(environment(sys.function(i))))) 451 nframes <- if (!is.null(cond$`_nframe`)) cond$`_nframe` else sys.parent() 452 messages <- list(conditionMessage(cond)) 453 ignore <- cond$`_ignore` 454 classes <- class(cond) 455 pids <- rep(cond$`_pid` %||% Sys.getpid(), length(calls)) 456 457 if (!embed) calls <- as.list(format_calls(calls, topenvs, nframes)) 458 459 if (is.null(cond$parent)) { 460 # Nothing to do, no parent 461 462 } else if (is.null(cond$parent$trace) || 463 !inherits(cond$parent, "rlib_error_2_0")) { 464 # If the parent does not have a trace, that means that it is using 465 # the same trace as us. We ignore traces from non-r-lib errors. 466 # E.g. rlang errors have a trace, but we do not use that. 467 parent <- cond 468 while (!is.null(parent <- parent$parent)) { 469 nframes <- c(nframes, parent$`_nframe`) 470 messages <- c(messages, list(conditionMessage(parent))) 471 ignore <- c(ignore, parent$`_ignore`) 472 } 473 474 } else { 475 # If it has a trace, that means that it is coming from another 476 # process or top level evaluation. In this case we'll merge the two 477 # traces. 478 pt <- cond$parent$trace 479 parents <- c(parents, pt$parents + length(calls)) 480 nframes <- c(nframes, pt$nframes + length(calls)) 481 ignore <- c(ignore, lapply(pt$ignore, function(x) x + length(calls))) 482 envs <- c(envs, pt$envs) 483 topenvs <- c(topenvs, pt$topenvs) 484 calls <- c(calls, pt$calls) 485 messages <- c(messages, pt$messages) 486 pids <- c(pids, pt$pids) 487 } 488 489 cond$trace <- new_trace( 490 calls, parents, envs, topenvs, nframes, messages, ignore, classes, 491 pids) 492 493 cond 494 } 495 496 topenvx <- function(x) { 497 topenv(x, matchThisEnv = err_env) 498 } 499 500 new_trace <- function (calls, parents, envs, topenvs, nframes, messages, 501 ignore, classes, pids) { 502 indices <- seq_along(calls) 503 structure( 504 list(calls = calls, parents = parents, envs = envs, topenvs = topenvs, 505 indices = indices, nframes = nframes, messages = messages, 506 ignore = ignore, classes = classes, pids = pids), 507 class = c("rlib_trace_2_0", "rlib_trace")) 508 } 509 510 env_label <- function(env) { 511 nm <- env_name(env) 512 if (nzchar(nm)) { 513 nm 514 } else { 515 env_address(env) 516 } 517 } 518 519 env_address <- function(env) { 520 class(env) <- "environment" 521 sub("^.*(0x[0-9a-f]+)>$", "\\1", format(env), perl = TRUE) 522 } 523 524 env_name <- function(env) { 525 if (identical(env, err_env)) { 526 return("") 527 } 528 if (identical(env, globalenv())) { 529 return("global") 530 } 531 if (identical(env, baseenv())) { 532 return("namespace:base") 533 } 534 if (identical(env, emptyenv())) { 535 return("empty") 536 } 537 nm <- environmentName(env) 538 if (isNamespace(env)) { 539 return(paste0("namespace:", nm)) 540 } 541 nm 542 } 543 544 # -- printing --------------------------------------------------------- 545 546 print_this <- function(x, ...) { 547 msg <- conditionMessage(x) 548 call <- conditionCall(x) 549 cl <- class(x)[1L] 550 if (!is.null(call)) { 551 cat("<", cl, " in ", format_call(call), ":\n ", msg, ">\n", sep = "") 552 } else { 553 cat("<", cl, ": ", msg, ">\n", sep = "") 554 } 555 556 print_srcref(x$call) 557 558 if (!identical(x$`_pid`, Sys.getpid())) { 559 cat(" in process", x$`_pid`, "\n") 560 } 561 562 invisible(x) 563 } 564 565 print_parents <- function(x, ...) { 566 if (!is.null(x$parent)) { 567 cat("-->\n") 568 print(x$parent) 569 } 570 invisible(x) 571 } 572 573 print_rlib_error_2_0 <- function(x, ...) { 574 print_this(x, ...) 575 print_parents(x, ...) 576 } 577 578 format_calls <- function(calls, topenv, nframes, messages = NULL) { 579 calls <- map2(calls, topenv, namespace_calls) 580 callstr <- vapply(calls, format_call_src, character(1)) 581 if (!is.null(messages)) { 582 callstr[nframes] <- 583 paste0(callstr[nframes], "\n", style_error_msg(messages), "\n") 584 } 585 callstr 586 } 587 588 print_rlib_trace_2_0 <- function(x, ...) { 589 cl <- paste0(" Stack trace:") 590 cat(sep = "", "\n", style_trace_title(cl), "\n\n") 591 callstr <- enumerate( 592 format_calls(x$calls, x$topenv, x$nframes, x$messages) 593 ) 594 595 # Ignore what we were told to ignore 596 ign <- integer() 597 for (iv in x$ignore) { 598 if (iv[2] == Inf) iv[2] <- length(callstr) 599 ign <- c(ign, iv[1]:iv[2]) 600 } 601 602 # Plus always ignore the tail. This is not always good for 603 # catch_rethrow(), but should be good otherwise 604 last_err_frame <- x$nframes[length(x$nframes)] 605 if (!is.na(last_err_frame) && last_err_frame < length(callstr)) { 606 ign <- c(ign, (last_err_frame+1):length(callstr)) 607 } 608 609 ign <- unique(ign) 610 if (length(ign)) callstr <- callstr[-ign] 611 612 # Add markers for subprocesses 613 if (length(unique(x$pids)) >= 2) { 614 pids <- x$pids[-ign] 615 pid_add <- which(!duplicated(pids)) 616 pid_str <- style_process(paste0("Process ", pids[pid_add], ":")) 617 callstr[pid_add] <- paste0(" ", pid_str, "\n", callstr[pid_add]) 618 } 619 620 cat(callstr, sep = "\n") 621 invisible(x) 622 } 623 624 capture_output <- function(expr) { 625 if (has_cli()) { 626 opts <- options(cli.num_colors = cli::num_ansi_colors()) 627 on.exit(options(opts), add = TRUE) 628 } 629 630 out <- NULL 631 file <- textConnection("out", "w", local = TRUE) 632 sink(file) 633 on.exit(sink(NULL), add = TRUE) 634 635 expr 636 if (is.null(out)) invisible(NULL) else out 637 } 638 639 is_interactive <- function() { 640 opt <- getOption("rlib_interactive") 641 if (isTRUE(opt)) { 642 TRUE 643 } else if (identical(opt, FALSE)) { 644 FALSE 645 } else if (tolower(getOption("knitr.in.progress", "false")) == "true") { 646 FALSE 647 } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") { 648 FALSE 649 } else if (identical(Sys.getenv("TESTTHAT"), "true")) { 650 FALSE 651 } else { 652 interactive() 653 } 654 } 655 656 onload_hook <- function() { 657 reg_env <- Sys.getenv("R_LIB_ERROR_REGISTER_PRINT_METHODS", "TRUE") 658 if (tolower(reg_env) != "false") { 659 registerS3method("print", "rlib_error_2_0", print_rlib_error_2_0, baseenv()) 660 registerS3method("print", "rlib_trace_2_0", print_rlib_trace_2_0, baseenv()) 661 } 662 } 663 664 namespace_calls <- function(call, env) { 665 if (length(call) < 1) return(call) 666 if (typeof(call[[1]]) != "symbol") return(call) 667 pkg <- strsplit(env, "^namespace:")[[1]][2] 668 if (is.na(pkg)) return(call) 669 call[[1]] <- substitute(p:::f, list(p = as.symbol(pkg), f = call[[1]])) 670 call 671 } 672 673 print_srcref <- function(call) { 674 src <- format_srcref(call) 675 if (length(src)) cat(sep = "", " ", src, "\n") 676 } 677 678 `%||%` <- function(l, r) if (is.null(l)) r else l 679 680 format_srcref <- function(call) { 681 if (is.null(call)) return(NULL) 682 file <- utils::getSrcFilename(call) 683 if (!length(file)) return(NULL) 684 dir <- utils::getSrcDirectory(call) 685 if (length(dir) && nzchar(dir) && nzchar(file)) { 686 srcfile <- attr(utils::getSrcref(call), "srcfile") 687 if (isTRUE(srcfile$isFile)) { 688 file <- file.path(dir, file) 689 } else { 690 file <- file.path("R", file) 691 } 692 } else { 693 file <- "??" 694 } 695 line <- utils::getSrcLocation(call) %||% "??" 696 col <- utils::getSrcLocation(call, which = "column") %||% "??" 697 style_srcref(paste0(file, ":", line, ":", col)) 698 } 699 700 format_call <- function(call) { 701 width <- getOption("width") 702 str <- format(call) 703 callstr <- if (length(str) > 1 || nchar(str[1]) > width) { 704 paste0(substr(str[1], 1, width - 5), " ...") 705 } else { 706 str[1] 707 } 708 style_call(callstr) 709 } 710 711 format_call_src <- function(call) { 712 callstr <- format_call(call) 713 src <- format_srcref(call) 714 if (length(src)) callstr <- paste0(callstr, "\n ", src) 715 callstr 716 } 717 718 enumerate <- function(x) { 719 paste0(style_numbers(paste0(" ", seq_along(x), ". ")), x) 720 } 721 722 map2 <- function (.x, .y, .f, ...) { 723 mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE, 724 USE.NAMES = FALSE) 725 } 726 727 bytes <- function(x) { 728 nchar(x, type = "bytes") 729 } 730 731 # -- printing, styles ------------------------------------------------- 732 733 has_cli <- function() "cli" %in% loadedNamespaces() 734 735 style_numbers <- function(x) { 736 if (has_cli()) cli::col_silver(x) else x 737 } 738 739 style_advice <- function(x) { 740 if (has_cli()) cli::col_silver(x) else x 741 } 742 743 style_srcref <- function(x) { 744 if (has_cli()) cli::style_italic(cli::col_cyan(x)) 745 } 746 747 style_error <- function(x) { 748 if (has_cli()) cli::style_bold(cli::col_red(x)) else x 749 } 750 751 style_error_msg <- function(x) { 752 sx <- paste0("\n x ", x, " ") 753 style_error(sx) 754 } 755 756 style_trace_title <- function(x) { 757 x 758 } 759 760 style_process <- function(x) { 761 if (has_cli()) cli::style_bold(x) else x 762 } 763 764 style_call <- function(x) { 765 if (!has_cli()) return(x) 766 call <- sub("^([^(]+)[(].*$", "\\1", x) 767 rest <- sub("^[^(]+([(].*)$", "\\1", x) 768 if (call == x || rest == x) return(x) 769 paste0(cli::col_yellow(call), rest) 770 } 771 772 err_env <- environment() 773 parent.env(err_env) <- baseenv() 774 775 structure( 776 list( 777 .internal = err_env, 778 new_cond = new_cond, 779 new_error = new_error, 780 throw = throw, 781 rethrow = rethrow, 782 catch_rethrow = catch_rethrow, 783 rethrow_call = rethrow_call, 784 add_trace_back = add_trace_back, 785 onload_hook = onload_hook, 786 print_this = print_this, 787 print_parents = print_parents 788 ), 789 class = c("standalone_errors", "standalone")) 790}) 791 792# These are optional, and feel free to remove them if you prefer to 793# call them through the `err` object. 794 795new_cond <- err$new_cond 796new_error <- err$new_error 797throw <- err$throw 798rethrow <- err$rethrow 799rethrow_call <- err$rethrow_call 800rethrow_call_with_cleanup <- err$.internal$rethrow_call_with_cleanup 801