Error chaining tweaks

R/author.R

@@ -80,7 +80,7 @@ use_author <- function(given = NULL, family = NULL, ..., role = "ctb") {
 
 }
 
-challenge_legacy_author_fields <- function(d = proj_desc()) {
+challenge_legacy_author_fields <- function(d = proj_desc(), .envir = parent.frame()) {
   has_legacy_field <- d$has_fields("Author") || d$has_fields("Maintainer")
   if (!has_legacy_field) {
     return(invisible())
@@ -95,13 +95,13 @@ challenge_legacy_author_fields <- function(d = proj_desc()) {
     "_" = "Convert to {.field Authors@R} with
            {.fun desc::desc_coerce_authors_at_r}, then delete the legacy fields."
   ))
-  if (ui_yep("Do you want to cancel this operation and sort that out first?")) {
+  if (ui_yep("Do you want to cancel this operation and sort that out first?", .envir = .envir)) {
     ui_abort("Cancelling.")
   }
   invisible()
 }
 
-check_author_is_novel <- function(given = NULL, family = NULL, d = proj_desc()) {
+check_author_is_novel <- function(given = NULL, family = NULL, d = proj_desc(), call = caller_env()) {
   authors <- d$get_authors()
   authors_given <- purrr::map(authors, "given")
   authors_family <- purrr::map(authors, "family")
@@ -114,7 +114,9 @@ check_author_is_novel <- function(given = NULL, family = NULL, d = proj_desc())
       "x" = "{.val {aut_name}} already appears in {.field Authors@R}.",
       " " = "Please make the desired change directly in DESCRIPTION or call the
              {.pkg desc} package directly."
-    ))
+      ),
+      call = call
+    )
   }
   invisible()
 }

R/block.R

@@ -87,7 +87,7 @@ block_show <- function(path, block_start = "# <<<", block_end = "# >>>") {
   lines[seq2(block[[1]], block[[2]])]
 }
 
-block_find <- function(lines, block_start = "# <<<", block_end = "# >>>") {
+block_find <- function(lines, block_start = "# <<<", block_end = "# >>>", call = caller_env()) {
   # No file
   if (is.null(lines)) {
     return(NULL)
@@ -106,7 +106,9 @@ block_find <- function(lines, block_start = "# <<<", block_end = "# >>>") {
       "Invalid block specification.",
       "Must start with {.code {block_start}} and end with
        {.code {block_end}}."
-    ))
+     ),
+     call = call
+    )
   }
 
   c(start + 1L, end - 1L)

R/git.R

@@ -252,7 +252,9 @@ use_git_remote <- function(name = "origin", url, overwrite = FALSE) {
     ui_abort(c(
       "Remote {.val {name}} already exists.",
       "Use {.code overwrite = TRUE} to edit it anyway."
-    ))
+      ),
+      call = parent.frame()
+    )
   }
 
   if (name %in% names(remotes)) {

R/github.R

@@ -91,7 +91,9 @@ use_github <- function(organisation = NULL,
     if (visibility_specified) {
       ui_abort("
         The {.arg visibility} setting is only relevant for organisation-owned
-        repos, within the context of certain GitHub Enterprise products.")
+        repos, within the context of certain GitHub Enterprise products.",
+        call = parent.frame()
+      )
     }
     visibility <- if (private) "private" else "public"
   }
@@ -106,7 +108,9 @@ use_github <- function(organisation = NULL,
       "x" = "Unable to discover a GitHub personal access token.",
       "i" = "A token is required in order to create and push to a new repo.",
       "_" = "Call {.run usethis::gh_token_help()} for help configuring a token."
-    ))
+      ),
+      call = parent.frame()
+    )
   }
   empirical_host <- parse_github_remotes(glue("{whoami$html_url}/REPO"))$host
   if (empirical_host != "github.com") {
@@ -255,20 +259,22 @@ has_github_links <- function() {
   has_github_url && has_github_issues
 }
 
-check_no_origin <- function() {
+check_no_origin <- function(call = caller_env()) {
   remotes <- git_remotes()
   if ("origin" %in% names(remotes)) {
     ui_abort(c(
       "x" = "This repo already has an {.val origin} remote, with value
              {.val {remotes[['origin']]}}.",
       "i" = "You can remove this setting with:",
       " " = '{.code usethis::use_git_remote("origin", url = NULL, overwrite = TRUE)}'
-    ))
+      ),
+      call = call
+    )
   }
   invisible()
 }
 
-check_no_github_repo <- function(owner, repo, host) {
+check_no_github_repo <- function(owner, repo, host, call = caller_env()) {
   repo_found <- tryCatch(
     {
       repo_info <- gh::gh(
@@ -285,5 +291,8 @@ check_no_github_repo <- function(owner, repo, host) {
   }
   spec <- glue("{owner}/{repo}")
   empirical_host <- parse_github_remotes(repo_info$html_url)$host
-  ui_abort("Repo {.val {spec}} already exists on {.val {empirical_host}}.")
+  ui_abort(
+    "Repo {.val {spec}} already exists on {.val {empirical_host}}.",
+    call = call
+  )
 }

R/pr.R

@@ -628,7 +628,7 @@ pr_clean <- function(number = NULL,
 # we're in DEFAULT branch of a fork. I wish everyone set up DEFAULT to track the
 # DEFAULT branch in the source repo, but this protects us against sub-optimal
 # setup.
-pr_pull_source_override <- function(tr = NULL, default_branch = NULL) {
+pr_pull_source_override <- function(tr = NULL, default_branch = NULL, call = caller_env()) {
   # naive selection of target repo; calling function should analyse the config
   tr <- tr %||% target_repo(github_get = FALSE, ask = FALSE)
 
@@ -639,7 +639,7 @@ pr_pull_source_override <- function(tr = NULL, default_branch = NULL) {
   if (current_branch != default_branch) {
     ui_abort("
       Internal error: {.fun pr_pull_source_override} should only be used when on
-      default branch.")
+      default branch.", call = call)
   }
 
   # guard against mis-configured forks, that have default branch tracking

R/proj.R

@@ -207,7 +207,7 @@ is_package <- function(base_path = proj_get()) {
   !is.null(res)
 }
 
-check_is_package <- function(whos_asking = NULL) {
+check_is_package <- function(whos_asking = NULL, call = caller_env()) {
   if (is_package()) {
     return(invisible())
   }
@@ -220,15 +220,16 @@ check_is_package <- function(whos_asking = NULL) {
       "x" = message
     )
   }
-  ui_abort(message)
+  ui_abort(message, call = call)
 }
 
-check_is_project <- function() {
+check_is_project <- function(call = caller_env()) {
   if (!possibly_in_proj()) {
     ui_abort(c(
       "We do not appear to be inside a valid project or package.",
       "Read more in the help for {.help usethis::proj_get}."
-    ))
+    ),
+    call = caller_env())
   }
 }
 

R/utils-git.R

@@ -27,15 +27,15 @@ uses_git <- function() {
   !is.null(repo)
 }
 
-check_uses_git <- function() {
+check_uses_git <- function(call = caller_env()) {
   if (uses_git()) {
     return(invisible())
   }
 
   ui_abort(c(
     "Cannot detect that project is already a Git repository.",
     "Do you need to run {.run usethis::use_git()}?"
-  ))
+    ), call = call)
 }
 
 git_init <- function() {

R/utils-github.R

@@ -68,7 +68,7 @@ parse_github_remotes <- function(x) {
   dat[c("name", "url", "host", "repo_owner", "repo_name", "protocol")]
 }
 
-parse_repo_url <- function(x) {
+parse_repo_url <- function(x, call = caller_env()) {
   check_name(x)
   dat <- re_match(x, github_remote_regex)
   if (is.na(dat$.match)) {
@@ -77,7 +77,10 @@ parse_repo_url <- function(x) {
     dat <- parse_github_remotes(x)
     # TODO: generalize here for GHE hosts that don't include 'github'
     if (!grepl("github", dat$host)) {
-      ui_abort("URL doesn't seem to be associated with GitHub: {.val {x}}")
+      ui_abort(
+        "URL doesn't seem to be associated with GitHub: {.val {x}}",
+        call = call
+      )
     }
     list(
       repo_spec = make_spec(owner = dat$repo_owner, repo = dat$repo_name),
@@ -162,7 +165,8 @@ github_remote_list <- function(these = c("origin", "upstream"), x = NULL) {
 #' @noRd
 github_remotes <- function(these = c("origin", "upstream"),
                            github_get = NA,
-                           x = NULL) {
+                           x = NULL,
+                           call = caller_env()) {
   grl <- github_remote_list(these = these, x = x)
   get_gh_repo <- function(repo_owner, repo_name,
                           api_url = "https://api.github.com") {
@@ -194,7 +198,9 @@ github_remotes <- function(these = c("origin", "upstream"),
       "Otherwise, you probably need to configure a personal access token (PAT)
        for {.val {oops_hosts}}.",
       "See {.run usethis::gh_token_help()} for advice."
-    ))
+      ),
+      call = call
+    )
   }
 
   grl$default_branch <- map_chr(repo_info, "default_branch", .default = NA)
@@ -331,17 +337,19 @@ github_remote_config <- function(github_get = NA) {
       ui_abort(c(
         "Internal error: Multiple GitHub hosts.",
         "{.val {grl$host}}"
-      ))
+      ), call = parent.frame())
     }
     if (length(unique(grl$github_got)) != 1) {
       ui_abort(c(
         "Internal error: Got GitHub API info for some remotes, but not all.",
         "Do all the remotes still exist? Do you still have access?"
-      ))
+      ), call = parent.frame())
     }
     if (length(unique(grl$perm_known)) != 1) {
-      ui_abort("
-        Internal error: Know GitHub permissions for some remotes, but not all.")
+      ui_abort(
+        "Internal error: Know GitHub permissions for some remotes, but not all.",
+        call = parent.frame()
+      )
     }
   }
   cfg$host_url <- unique(grl$host_url)
@@ -468,15 +476,16 @@ target_repo <- function(cfg = NULL,
                         github_get = NA,
                         role = c("source", "primary"),
                         ask = is_interactive(),
-                        ok_configs = c("ours", "fork", "theirs")) {
+                        ok_configs = c("ours", "fork", "theirs"),
+                        call = caller_env()) {
   cfg <- cfg %||% github_remote_config(github_get = github_get)
   stopifnot(inherits(cfg, "github_remote_config"))
   role <- match.arg(role)
 
-  check_for_bad_config(cfg)
+  check_for_bad_config(cfg, call = call)
 
   if (isTRUE(github_get)) {
-    check_for_config(cfg, ok_configs = ok_configs)
+    check_for_config(cfg, ok_configs = ok_configs, call = call)
   }
 
   # upstream only
@@ -508,8 +517,9 @@ target_repo <- function(cfg = NULL,
 }
 
 target_repo_spec <- function(role = c("source", "primary"),
-                             ask = is_interactive()) {
-  tr <- target_repo(role = match.arg(role), ask = ask)
+                             ask = is_interactive(),
+                             call = caller_env()) {
+  tr <- target_repo(role = match.arg(role), ask = ask, call = call)
   tr$repo_spec
 }
 
@@ -600,15 +610,16 @@ ui_github_remote_config_wat <- function(cfg) {
   )
 }
 
-stop_bad_github_remote_config <- function(cfg) {
+stop_bad_github_remote_config <- function(cfg, call = caller_env()) {
   ui_abort(
     github_remote_config_wat(cfg, context = "abort"),
     class = "usethis_error_bad_github_remote_config",
-    cfg = cfg
+    cfg = cfg,
+    call = call
   )
 }
 
-stop_maybe_github_remote_config <- function(cfg) {
+stop_maybe_github_remote_config <- function(cfg, call = caller_env()) {
   msg <- c(
     ui_pre_glue("
       Pull request functions can't work with GitHub remote configuration:
@@ -623,7 +634,8 @@ stop_maybe_github_remote_config <- function(cfg) {
   ui_abort(
     message = unlist(msg),
     class = "usethis_error_invalid_pr_config",
-    cfg = cfg
+    cfg = cfg,
+    call = call
   )
 }
 
@@ -633,49 +645,53 @@ check_for_bad_config <- function(cfg,
                                    "fork_upstream_is_not_origin_parent",
                                    "fork_cannot_push_origin",
                                    "upstream_but_origin_is_not_fork"
-                                 )) {
+                                 ),
+                                 call = caller_env()) {
   if (cfg$type %in% bad_configs) {
-    stop_bad_github_remote_config(cfg)
+    stop_bad_github_remote_config(cfg, call = call)
   }
   invisible()
 }
 
-check_for_maybe_config <- function(cfg) {
+check_for_maybe_config <- function(cfg, call = caller_env()) {
   maybe_configs <- grep("^maybe_", all_configs(), value = TRUE)
   if (cfg$type %in% maybe_configs) {
-    stop_maybe_github_remote_config(cfg)
+    stop_maybe_github_remote_config(cfg, call = call)
   }
   invisible()
 }
 
 check_for_config <- function(cfg = NULL,
-                             ok_configs = c("ours", "fork", "theirs")) {
+                             ok_configs = c("ours", "fork", "theirs"),
+                             call = caller_env()) {
   cfg <- cfg %||% github_remote_config(github_get = TRUE)
   stopifnot(inherits(cfg, "github_remote_config"))
 
   if (cfg$type %in% ok_configs) {
     return(invisible(cfg))
   }
 
-  check_for_maybe_config(cfg)
+  check_for_maybe_config(cfg, call = call)
 
   bad_configs <- grep("^maybe_", all_configs(), invert = TRUE, value = TRUE)
   bad_configs <- setdiff(bad_configs, ok_configs)
 
-  check_for_bad_config(cfg, bad_configs = bad_configs)
+  check_for_bad_config(cfg, bad_configs = bad_configs, call = call)
 
-  ui_abort("
-    Internal error: Unexpected GitHub remote configuration: {.val {cfg$type}}.")
+  ui_abort(
+    "Internal error: Unexpected GitHub remote configuration: {.val {cfg$type}}.",
+    call = call
+  )
 }
 
 check_can_push <- function(tr = target_repo(github_get = TRUE),
-                           objective = "for this operation") {
+                           objective = "for this operation", call = caller_env()) {
   if (isTRUE(tr$can_push)) {
     return(invisible())
   }
   ui_abort("
     You don't seem to have push access for {.val {tr$repo_spec}}, which
-    is required {objective}.")
+    is required {objective}.", call = call)
 }
 
 # github remote configurations -------------------------------------------------