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