# Standalone file: do not edit by hand
# Source: https://github.com/Yunuuuu/standalone/blob/HEAD/R/standalone-pkg.R
# Generated by: usethis::use_standalone("Yunuuuu/standalone", "pkg")
# ----------------------------------------------------------------------
#
# ---
# repo: Yunuuuu/standalone
# file: standalone-pkg.R
# last-updated: 2025-04-10
# license: https://unlicense.org
# imports: [utils]
# ---

# This file contains various helper utilities, including common functions
# used across multiple packages I have developed. Some functions depend on
# other packages that are not listed in Imports, so use them with caution.

# ## Changelog
# 2025-04-10
# - simplify `from_namespace`
#
# 2025-03-30
# - Add `use_github_release`
#
# 2025-03-12
# - Add `from_namespace`
#
# 2025-03-10:
# - Add `on_exit`
#
# 2025-03-08:
# - Add `pkg_extdata`
# - Add `defer`
#
# 2025-03-04:
# - Add `%||%`
#
# 2025-03-03:
# - Add `rd_collect_family`
# - Add `oxford_and`
# - Add `oxford_or`
# - Add `code_quote`
# - Add `oxford_comma`
#
# 2025-02-26:
# - Add `is_installed`
# - Add `install_pkgs`
# - Add `pkg_nm`
# - Add `pkg_namespace`
#
# nocov start

`%||%` <- function(x, y) if (is.null(x)) y else x

is_installed <- local({
    cache <- new.env(parent = emptyenv())
    function(pkg, version = NULL) {
        id <- if (is.null(version)) pkg else paste(pkg, version, sep = ":")
        out <- cache[[id]]
        if (is.null(out)) {
            if (is.null(version)) {
                out <- requireNamespace(pkg, quietly = TRUE)
            } else {
                out <- requireNamespace(pkg, quietly = TRUE) &&
                    utils::packageVersion(pkg) >= version
            }
            assign(id, out, envir = cache, inherits = FALSE)
        }
        out
    }
})

install_pkgs <- function(pkgs) {
    if (is_installed("pak")) {
        getExportedValue("pak", "pkg_install")(pkgs, ask = FALSE)
    } else {
        utils::install.packages(pkgs)
    }
}

pkg_nm <- function() utils::packageName(environment())

pkg_namespace <- function() topenv(environment())

pkg_extdata <- function(..., mustWork = TRUE) {
    system.file("extdata", ..., package = pkg_nm(), mustWork = mustWork)
}

############################################################
# I'm having trouble connecting to GitHub, and it seems that `gert` does not
# respect the proxy settings in my Git config. To work around this, I modified
# `usethis::use_github_release()` to skip the check that relies on the `gert`
# package.
use_github_release <- function(publish = TRUE) {
    usethis_ns <- getNamespace("usethis")
    usethis <- function(fun, ...) {
        get(x = fun, envir = usethis_ns, inherits = FALSE, ...)
    }
    usethis("check_is_package")("use_github_release()")
    tr <- usethis("target_repo")(
        github_get = TRUE,
        ok_configs = c("ours", "fork")
    )
    usethis("check_can_push")(tr = tr, "to create a release")
    dat <- usethis("get_release_data")(tr)
    release_name <- paste(dat$Package, dat$Version)
    tag_name <- sprintf("v%s", dat$Version)
    usethis("kv_line")("Release name", release_name)
    usethis("kv_line")("Tag name", tag_name)
    usethis("kv_line")("SHA", dat$SHA)
    usethis("check_github_has_SHA")(SHA = dat$SHA, tr = tr)
    on_cran <- !is.null(usethis("cran_version")())
    news <- usethis("get_release_news")(
        SHA = dat$SHA, tr = tr, on_cran = on_cran
    )
    gh <- usethis("gh_tr")(tr)
    usethis("ui_bullets")("Publishing {tag_name} release to GitHub")
    release <- gh( # nolint
        "POST /repos/{owner}/{repo}/releases",
        name = release_name,
        tag_name = tag_name,
        target_commitish = dat$SHA,
        body = news,
        draft = !publish
    )
    usethis("ui_bullets")("Release at {.url {release$html_url}}")
    if (!is.null(dat$file)) {
        usethis("ui_bullets")("Deleting {.path {dat$file}}")
        getExportedValue("fs", "file_delete")(dat$file)
    }
    invisible()
}

############################################################
from_namespace <- local({
    namespace <- NULL
    function(package, name, mode = "any") {
        if (is.null(namespace)) namespace <<- getNamespace(package)
        get(x = name, envir = namespace, inherits = FALSE, mode = mode)
    }
})

# Need `rlang` package, can support `quosure`
on_exit <- function(expr, envir = parent.frame(), after = TRUE, add = TRUE) {
    expr <- getExportedValue("rlang", "enquo")(expr)
    defer(
        getExportedValue("rlang", "eval_tidy")(expr),
        envir = envir,
        after = after,
        add
    )
}

# Just like `withr::defer()`, don't depend on `rlang` package
defer <- function(expr, envir = parent.frame(), after = TRUE, add = TRUE) {
    thunk <- as.call(list(function() expr))
    do.call(base::on.exit, list(thunk, add = add, after = after), envir = envir)
}

# utils function to collapse characters ---------------------------
oxford_and <- function(x, code = TRUE, quote = TRUE, sep = ", ") {
    oxford_comma(code_quote(x, code, quote), sep = sep, final = "and")
}

oxford_or <- function(x, code = TRUE, quote = TRUE, sep = ", ") {
    oxford_comma(code_quote(x, code, quote), sep = sep, final = "or")
}

code_quote <- function(x, code = TRUE, quote = TRUE) {
    if (quote) x <- paste0("\"", x, "\"")
    if (code) x <- paste0("`", x, "`")
    x
}

oxford_comma <- function(x, sep = ", ", final = "and") {
    n <- length(x)

    if (n < 2L) return(x) # styler: off

    head <- x[seq_len(n - 1L)]
    last <- x[n]

    head <- paste(head, collapse = sep)

    # Write a or b. But a, b, or c.
    if (n > 2L) {
        paste0(head, sep, final, " ", last)
    } else {
        paste0(head, " ", final, " ", last)
    }
}

# Need `roxygen2` package
#' @description add `@eval rd_collect_family("myfamily")` to the functions in
#' your package. This will automatically generate a section listing all
#' functions tagged with `@family myfamily`.
#' @param family A string specifying the family name.
#' @param section_title A string specifying the section title.
#' @param code_style A boolean indicating whether to apply code formatting
#' to function names.
#' @noRd
rd_collect_family <- function(
    family,
    section_title = paste(family, "family"),
    code_style = TRUE) {
    # get blocks objects from the roxygenize function
    blocks <- NULL
    pos <- sys.nframe()
    while (pos > 0L) {
        if (!is.null(call <- sys.call(-pos))) {
            fn <- eval(.subset2(call, 1L), sys.frame(-(pos + 1L)))
            env <- sys.frame(-pos)
            if (
                identical(fn, getExportedValue("roxygen2", "roxygenize")) &&
                    exists("blocks", envir = env, inherits = FALSE)
            ) {
                blocks <- get("blocks", envir = env, inherits = FALSE)
                break
            }
        }
        pos <- pos - 1L
    }

    # identify the blocks with family of the same tag specified in `family`
    blocks <- blocks[
        vapply(
            blocks,
            function(block) {
                getExportedValue("roxygen2", "block_has_tags")(
                    block,
                    "family"
                ) &&
                    identical(
                        getExportedValue("roxygen2", "block_get_tag_value")(
                            block,
                            "family"
                        ),
                        family
                    )
            },
            logical(1L),
            USE.NAMES = FALSE
        )
    ]
    if (length(blocks) == 0L) return(character()) # styler: off

    # extracted the function name
    funs <- vapply(
        blocks,
        function(block) {
            as.character(.subset2(block$call, 2L))
        },
        character(1L),
        USE.NAMES = FALSE
    )
    if (code_style) {
        items <- sprintf("\\code{\\link[=%s]{%s()}}", funs, funs)
    } else {
        items <- sprintf("\\link[=%s]{%s()}", funs, funs)
    }
    c(
        sprintf("@section %s:", section_title),
        "\\itemize{",
        sprintf("  \\item %s", items),
        "}"
    )
}

# nocov end
