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

#' @export
.ps.errors.globalErrorHandler <- function(cnd) {
    # Unlike C stack overflow errors, expressions nested too deeply errors allow
    # calling handlers. But since we run R code, we need to temporarily bump the
    # threshold to give a little room while we handle the error.
    if (inherits(cnd, "expressionStackOverflowError")) {
        old <- options(expressions = getOption("expressions") + 500)
        defer(options(old))
    }

    if (debug_should_break_on_condition("error")) {
        debug_set_stopped_reason(cnd)

        # Drop in the debugger
        browser()

        # Fall through to our error handler when we're done debugging
    }

    # This reproduces the behaviour of R's default error handler:
    # - Invoke `getOption("error")`
    # - Save backtrace for `traceback()`
    # - Jump to top-level, or back to browser if we're in one
    defer({
        invoke_option_error_handler()
        poke_traceback()

        if (!is.null(findRestart("browser"))) {
            invokeRestart("browser")
        } else {
            invokeRestart("abort")
        }
    })

    if (!.ps.is_installed("rlang")) {
        # rlang is not installed, no option except to use the base handler
        return(handle_error_base(cnd))
    }

    if (!inherits(cnd, "rlang_error") && !option_ark_error_entrace()) {
        # We have a non-rlang error, but the user requested we dont entrace it
        return(handle_error_base(cnd))
    }

    if (!inherits(cnd, "rlang_error")) {
        base_cnd <- cnd
        cnd <- rlang::catch_cnd(rlang::entrace(cnd))

        # rlang might decide not to entrace, e.g. when `recover` is set as
        # global error handler
        if (is.null(cnd)) {
            return(handle_error_base(base_cnd))
        }
    }

    handle_error_rlang(cnd)
}

#' @export
.ps.errors.globalWarningHandler <- function(cnd) {
    # If the debugger requested that we break on warnings, drop into `browser()`
    if (debug_should_break_on_condition("warning")) {
        debug_set_stopped_reason(cnd)

        # Drop in the debugger
        browser()

        # Fall through to our error handler when we're done debugging
    }

    # Fall through to default warning handling
}

.ps.errors.globalMessageHandler <- function(cnd) {
    # Decline to handle if we can't muffle the message (should only happen
    # in extremely rare cases)
    if (is.null(findRestart("muffleMessage"))) {
        return()
    }

    msg <- conditionMessage(cnd)

    if (inherits(cnd, "rlang_message")) {
        # Special-case for rlang messages which use the implicit trailing
        # line feed approach of warnings and errors. See
        # https://github.com/posit-dev/positron/issues/1878 for context and
        # https://github.com/r-lib/rlang/issues/1677 for a discussion about
        # making rlang messages consistent with base messages rather than
        # warnings and errors.
        msg <- paste0(msg, "\n")
    }

    # Output the condition message to the relevant stream (normally
    # stdout). Note that for historical reasons, messages include a
    # trailing newline
    cat(msg, file = default_message_file())

    # Silence default message handling
    invokeRestart("muffleMessage")
}

globalInterruptHandler <- function(cnd) {
    if (
        is_interrupting_for_debugger() ||
            debug_should_break_on_condition("interrupt")
    ) {
        debug_set_stopped_reason_pause()
        browser()
        base::.tryResumeInterrupt()
    }
}

#' @export
.ps.errors.traceback <- function() {
    traceback <- get0(".Traceback", baseenv(), ifnotfound = list())

    # Be defensive against potential `NULL` as this comes from foreign code
    if (!length(traceback)) {
        return(character())
    }

    format_traceback(traceback)
}

# If a sink is active (either on output or on messages) messages
# are always streamed to `stderr`. This follows rlang behaviour
# and ensures messages can be sinked from stderr consistently.
#
# Unlike rlang we don't make an exception for non-interactive sessions
# since Ark is meant to be run interactively.
default_message_file <- function() {
    if (
        sink.number("output") == 0 &&
            sink.number("message") == 2
    ) {
        stdout()
    } else {
        stderr()
    }
}

handle_error_base <- function(cnd) {
    # Rough equivalent of `rlang::cnd_message(prefix = TRUE)`
    evalue <- conditionMessage(cnd)
    evalue <- paste0("Error:\n", evalue)

    traceback <- sys.calls()

    # Converts pairlist to list, and rare `NULL` result to `list()`
    traceback <- as.list(traceback)

    n <- length(traceback)
    if (n >= 3L) {
        # Remove last three frames:
        # - 1 for `handle_error_base()`
        # - 2 for global handler frames
        n <- n - 3L
        traceback <- traceback[seq_len(n)]
    }
    traceback <- format_traceback(traceback)

    .ps.Call("ps_record_error", evalue, traceback)
}

#' @param traceback A list of calls.
format_traceback <- function(calls = list()) {
    # Calls the function of the same name in the harp namespace
    .ps.Call("ps_format_traceback", calls)
}

handle_error_rlang <- function(cnd) {
    evalue <- rlang::cnd_message(cnd, prefix = TRUE)
    traceback <- cnd$trace

    if (is.null(traceback)) {
        traceback <- character()
    } else if (rlang::trace_length(traceback) == 0L) {
        # Avoid showing traceback tree node when the trace is empty
        traceback <- character()
    } else {
        # Calls rlang specific `format()` method for the traceback
        traceback <- format(traceback)
    }

    .ps.Call("ps_record_error", evalue, traceback)
}

option_ark_error_entrace <- function() {
    # TODO: Wire this up to a Positron setting for easy toggling?
    isTRUE(getOption("ark.error_entrace", default = TRUE))
}

rust_backtrace <- function() {
    .ps.Call("ps_rust_backtrace")
}

# Implements base R behaviour in options.c and errors.c
invoke_option_error_handler <- function() {
    handler <- getOption("error")

    if (is.function(handler)) {
        handler <- as.call(list(handler))
    }

    if (!is.expression(handler)) {
        handler <- as.expression(list(handler))
    }

    delayedAssign("non_local_return", return())

    for (hnd in handler) {
        # Use `withCallingHandlers()` instead of `tryCatch()` to avoid making
        # the call stack too complex. We might be running `options(error = browser())`
        withCallingHandlers(
            {
                # Evaluate from a promise to keep a simple call stack.
                # We do evaluate from a closure wrapped in `handler()` so that R
                # can infer a named call, for instance in the "Called from:"
                # output of `browser()`.
                error_handler <- eval(bquote(function() .(hnd)))
                error_handler()
            },
            error = function(err) {
                # Disable error handler to avoid cascading errors
                options(error = NULL)

                # We don't let the error propagate to avoid a confusing sequence of
                # error messages from R, such as "Error during wrapup"
                writeLines(
                    c(
                        "The `getOption(\"error\")` handler failed.",
                        "This option was unset to avoid cascading errors.",
                        "Caused by:",
                        conditionMessage(err)
                    ),
                    con = stderr()
                )

                # Bail early
                non_local_return
            }
        )
    }
}

poke_traceback <- function() {
    traceback <- sys.calls()

    # Remove handling context
    traceback <- utils::head(traceback, -4)

    # Reverse so that more recent calls are first
    traceback <- rev(traceback)

    # `traceback()` expects a pairlist
    traceback <- as.pairlist(traceback)

    base_bind(as.symbol(".Traceback"), traceback)
}

# Because this init function calls `globalCallingHandlers()`, it must be called
# without any handlers on the stack (so not from `initialize()`)
initialize_errors <- function() {
    if (getRversion() < "4.0.0") {
        # `globalCallingHandlers()` didn't exist here.
        # In this case, we simply print errors to the console.
        # We will never throw an `ExecuteReplyException` here.
        return(invisible(NULL))
    }

    # Unregister all handlers and hold onto them
    handlers <- globalCallingHandlers(NULL)

    # Inject our global error handler at the end.
    # This allows other existing error handlers to run ahead of us.
    handlers <- c(
        handlers,
        list(
            error = .ps.errors.globalErrorHandler,
            warning = .ps.errors.globalWarningHandler,
            message = .ps.errors.globalMessageHandler,
            interrupt = globalInterruptHandler
        )
    )
    do.call(globalCallingHandlers, handlers)

    invisible(NULL)
}

is_interrupting_for_debugger <- function() {
    isTRUE(.ps.Call("ps_is_interrupting_for_debugger"))
}

debug_should_break_on_condition <- function(filter) {
    isTRUE(.ps.Call("ps_debug_should_break_on_condition", filter))
}

debug_set_stopped_reason_pause <- function() {
    .ps.Call("ps_debug_set_stopped_reason_pause")
}

debug_set_stopped_reason <- function(cnd) {
    # Set the stopped reason so DAP knows we stopped due to an exception.
    # Call `conditionMessage()`defensively since it invokes foreign code
    # that might be buggy.
    message <- tryCatch(
        conditionMessage(cnd),
        error = function(e) "<error getting condition message>"
    )

    if (.ps.is_installed("cli")) {
        message <- cli::ansi_strip(message)
    }

    .ps.Call("ps_debug_set_stopped_reason", class(cnd)[[1]], message)
}
