#
# hooks.R
#
# Copyright (C) 2023-2026 Posit Software, PBC. All rights reserved.
#
#

initialize_hooks <- function() {
    rebind("utils", "View", view_hook, namespace = TRUE)
    rebind("base", "debug", new_ark_debug(base::debug), namespace = TRUE)
    rebind(
        "base",
        "debugonce",
        new_ark_debug(base::debugonce),
        namespace = TRUE
    )

    rebind(
        "utils",
        "recover",
        # Keep this wrapped up this way for a better "Called from:" call
        function() ark_recover(),
        namespace = TRUE
    )
    register_getHook_hook()

    if (is_windows()) {
        rebind("utils", "timestamp", windows_timestamp, namespace = TRUE)
    }
}

rebind <- function(pkg, name, value, namespace = FALSE) {
    pkg_bind(
        pkg = pkg,
        name = name,
        value = value
    )

    if (namespace) {
        ns_bind(
            pkg = pkg,
            name = name,
            value = value
        )
    }
}

#' Override a function within an attached package
#'
#' Assumes the package is attached, typically used for base packages like base or utils.
#' - `pkg_bind()` replaces the binding in the package environment on the search
#'   path for unnamespaced calls.
#' - `ns_bind()` replaces the binding for namespaced calls.
#'
#' TODO: Will cause ark to fail to start if `option(defaultPackages = character())`
#' or `R_DEFAULT_PACKAGES=NULL` are set! One idea is to register an `onAttach()`
#' hook here and use that if the package is not loaded yet.
pkg_bind <- function(pkg, name, value) {
    env <- sprintf("package:%s", pkg)
    env <- as.environment(env)

    fn <- get0(name, envir = env, mode = "function", inherits = FALSE)

    if (is.null(fn)) {
        msg <- sprintf(
            "Can't register hook: function `%s::%s` not found.",
            pkg,
            name
        )
        stop(msg, call. = FALSE)
    }

    # Check formals, but if we are wrong, only panic in debug builds.
    # Not worth it to bring the whole system down for this.
    # Checked in CI across all supported R versions.
    if (is_debug_build() && !identical(formals(fn), formals(value))) {
        msg <- sprintf(
            "Can't register hook: replacement for `%s::%s` does not have the same arguments.",
            pkg,
            name
        )
        stop(msg, call. = FALSE)
    }

    old <- env_bind_force(env, name, value)
    invisible(old)
}

ns_bind <- function(pkg, name, value) {
    ns <- asNamespace(pkg)

    fn <- get0(name, envir = ns, mode = "function", inherits = FALSE)

    if (is.null(fn)) {
        msg <- sprintf("Can't replace `%s` in the '%s' namespace.", name, pkg)
        stop(msg, call. = FALSE)
    }

    # Check formals, but if we are wrong, only panic in debug builds.
    # Not worth it to bring the whole system down for this.
    # Checked in CI across all supported R versions.
    if (is_debug_build() && !identical(formals(fn), formals(value))) {
        msg <- sprintf(
            "Can't replace `%s` in the '%s' namespace: replacement does not have the same arguments.",
            pkg,
            name
        )
        stop(msg, call. = FALSE)
    }

    old <- env_bind_force(ns, name, value)
    invisible(old)
}

# R only allows `onLoad` hooks for named packages, not for any package that
# might be loaded in the session. We modify `getHook()` to add support for
# such a general event.
register_getHook_hook <- function() {
    ns <- asNamespace("base")
    local_unlock_binding(ns, "getHook")

    ns[["getHook"]] <- function(hookName, ...) {
        hooks <- get0(
            hookName,
            envir = .userHooksEnv,
            inherits = FALSE,
            ifnotfound = list()
        )

        if (!grepl("^UserHook::.*::onLoad$", hookName)) {
            return(hooks)
        }

        is_ark_hook <- function(fn) {
            inherits(fn, "ark_onload_hook")
        }

        # Inject our onload hook but only if not already there
        if (is.na(Position(is_ark_hook, hooks))) {
            c(list(ark_onload_hook), hooks)
        } else {
            hooks
        }
    }
}

ark_onload_hook <- function(pkg, path) {
    # For compatibility with older pkgload versions
    # https://github.com/r-lib/pkgload/commit/b4e178bd52182a2d7f650754830c69fe51be4b8b
    if (missing(path)) {
        path <- NULL
    }

    # Just in case
    if (!is_string(pkg) || !is_string(path)) {
        return()
    }

    if (pkg == "cli") {
        the$cli_version <- utils::packageVersion("cli")
    }

    check_version(pkg)

    .ps.Call("ps_onload_hook", pkg, path)
}

ark_onload_hook <- structure(
    ark_onload_hook,
    class = c("ark_onload_hook", "function")
)

check_version <- function(pkg) {
    version <- utils::packageVersion(pkg)

    switch(
        pkg,
        roxygen2 = if (version <= "7.3.1") {
            message(paste(
                sep = "\n",
                sprintf(
                    "%s You are using roxygen2 %s. It is recommended to update to roxygen2 >= 7.3.2 when running inside Ark.",
                    ansi_info(),
                    version
                ),
                sprintf(
                    "%s See https://github.com/posit-dev/positron/issues/3053",
                    ansi_info()
                )
            ))
        }
    )
}

.ps.run_session_init_hooks <- function(start_type = c("new", "restart")) {
    start_type <- match.arg(start_type)
    hooks <- getHook("positron.session_init")

    for (hook_fn in hooks) {
        tryCatch(
            hook_fn(start_type),
            error = function(err) {
                log_warning(sprintf(
                    "Error in positron.session_init hook: %s",
                    conditionMessage(err)
                ))
            }
        )
    }

    invisible(NULL)
}

.ps.run_session_reconnect_hooks <- function() {
    hooks <- getHook("positron.session_reconnect")

    for (hook_fn in hooks) {
        tryCatch(
            hook_fn(),
            error = function(err) {
                log_warning(sprintf(
                    "Error in positron.session_reconnect hook: %s",
                    conditionMessage(err)
                ))
            }
        )
    }

    invisible(NULL)
}

# We don't support `utils::recover()` in Ark, but the same functionality is
# provided via the call stack pane of IDEs. So replace it by `browser()` so that
# people can enter the debugger on error using the familiar `options(error =
# recover)` gesture.
ark_recover <- function(...) {
    browser()
}
