#' Add or Remove a Global 'progression' Handler
#'
#' @param action (character string)
#' If `"add"`, a global handler is added.
#' If `"remove"`, it is removed, if it exists.
#' If `"query"`, checks whether a handler is registered or not.
#'
#' @return Returns TRUE if a handler is registered, otherwise FALSE.
#' If `action = "query"`, the value is visible, otherwise invisible.
#'
#' @section Requirements:
#' This function requires R (>= 4.0.0) - the version in which global calling
#' handlers where introduces.
#'
#' @example incl/register_global_progression_handler.R
#'
#' @keywords internal
register_global_progression_handler <- function(action = c("add", "remove", "query")) {
  action <- match.arg(action[1], choices = c("add", "remove", "query", "status"))

  if (getRversion() < "4.0.0") {
    warning("register_global_progression_handler() requires R (>= 4.0.0)")
    return(invisible(FALSE))
  }

  ## All existing handlers
  handlers <- globalCallingHandlers()

  exists <- vapply(handlers, FUN = identical, global_progression_handler, FUN.VALUE = FALSE)
  if (sum(exists) > 1L) {
    warning("Detected more than one registered 'global_progression_handler'. Did you register it manually?")
  }
  
  if (action == "add") {
    if (!any(exists)) {
      globalCallingHandlers(condition = global_progression_handler)
    }
    invisible(TRUE)
  } else if (action == "remove") {
    global_progression_handler(control_progression("shutdown"))
    handlers <- handlers[!exists]
    ## Remove all
    globalCallingHandlers(NULL)
    ## Add back the ones we didn't drop
    globalCallingHandlers(handlers)
    invisible(FALSE)
  } else if (action == "query") {
    any(exists)
  } else if (action == "status") {
    global_progression_handler(control_progression("status"))
  }
}


#' A Global Calling Handler For 'progression':s
#'
#' @param condition A logical scalar or a condition object.
#'
#' @return Nothing.
#'
#' @section Requirements:
#' This function requires R (>= 4.0.0) - the version in which global calling
#' handlers where introduces.
#' 
#' @keywords internal
global_progression_handler <- local({
  active <- TRUE
  
  current_progressor_uuid <- NULL
  calling_handler <- NULL
  delays <- NULL
  stdout_file <- NULL
  capture_conditions <- NA
  conditions <- list()
  genv <- globalenv()

  update_calling_handler <- function() {
    handlers <- handlers()
    # Nothing to do?
    if (length(handlers) == 0L) return(NULL)

    handlers <- as_progression_handler(handlers)

    # Nothing to do?
    if (length(handlers) == 0L) return(NULL)

    ## Do we need to buffer?
    delays <<- use_delays(handlers)

    calling_handler <<- make_calling_handler(handlers)
  }

  interrupt_calling_handler <- function(progression, debug = FALSE) {
    if (is.null(calling_handler)) return()
    
    ## Don't capture conditions that are produced by progression handlers
    capture_conditions <<- FALSE
    on.exit(capture_conditions <<- TRUE)
  
    ## Any buffered output to flush?
    if (isTRUE(attr(delays$terminal, "flush"))) {
      if (length(conditions) > 0L || has_buffered_stdout(stdout_file)) {
        calling_handler(control_progression("hide"))
        stdout_file <<- flush_stdout(stdout_file, close = FALSE)
        conditions <<- flush_conditions(conditions)
      }
    }
  
    calling_handler(progression)
  }

  finish <- function(progression = control_progression("shutdown"), debug = FALSE) {
    finished <- FALSE

    ## Is progress handler active?
    if (!is.null(current_progressor_uuid)) {
      if (debug) message(" - shutdown progression handlers")
      if (!is.null(calling_handler)) {
        stdout_file <<- delay_stdout(delays, stdout_file = stdout_file)
        finished <- calling_handler(progression)
        ## Note that we might not be able to close 'stdout_file' due
        ## to blocking, non-balanced sinks
        stdout_file <<- flush_stdout(stdout_file, close = TRUE, must_work = FALSE)
        conditions <<- flush_conditions(conditions)
        delays <<- NULL
        if (debug) message(" - finished: ", finished)
      } else {
        finished <- TRUE
      }
    } else {
      if (debug) message(" - no active global progression handler")
    }

    ## Note that we might not have been able to close 'stdout_file' in previous
    ## calls to finish() due to blocking, non-balanced sinks. Try again here,
    ## just in case
    if (!is.null(stdout_file)) {
      stdout_file <<- flush_stdout(stdout_file, close = TRUE, must_work = FALSE)
    }

    current_progressor_uuid <<- NULL
    calling_handler <<- NULL
    capture_conditions <<- NA
    finished <- TRUE
    stop_if_not(length(conditions) == 0L, is.null(delays), isTRUE(finished), is.na(capture_conditions))
    
    finished
  }

  handle_progression <- function(progression, debug = getOption("progressr.global.debug", FALSE)) {
    ## To please R CMD check
    calling_handler <- NULL; rm(list = "calling_handler")

    ## Don't capture conditions that are produced by progression handlers
    last_capture_conditions <- capture_conditions
    capture_conditions <<- FALSE
    on.exit({
      if (is.null(current_progressor_uuid)) {
        capture_conditions <<- NA
      } else if (!is.na(capture_conditions)) {
        capture_conditions <<- TRUE
      }
    })

    stop_if_not(inherits(progression, "progression"))
    
    assign(".Last.progression", value = progression, envir = genv, inherits = FALSE)

    if (debug) message(sprintf("*** Caught a %s condition:", sQuote(class(progression)[1])))
    progressor_uuid <- progression[["progressor_uuid"]]
    if (debug) message(" - source: ", progressor_uuid)
    
    ## Listen to this progressor?
    if (!is.null(current_progressor_uuid) &&
        !identical(progressor_uuid, current_progressor_uuid)) {
      if (debug) message(" - action: ignoring, already listening to another")
      return()
    }


    if (!is.null(calling_handler) && !is.null(delays)) {
      ## Any buffered output to flush?
      if (isTRUE(attr(delays$terminal, "flush"))) {
        if (length(conditions) > 0L || has_buffered_stdout(stdout_file)) {
          calling_handler(control_progression("hide"))
          stdout_file <<- flush_stdout(stdout_file, close = FALSE)
          stop_if_not(inherits(stdout_file, "connection"))
          conditions <<- flush_conditions(conditions)
          calling_handler(control_progression("unhide"))
        }
      }
    }

    type <- progression[["type"]]
    if (debug) message(" - type: ", type)
  
    if (type == "initiate") {
      if (identical(progressor_uuid, current_progressor_uuid)) {
        stop(sprintf("INTERNAL ERROR: Already listening to this progressor which just sent another %s request", sQuote(type)))
      }
      if (debug) message(" - start listening")
#      finished <- finish(debug = debug)
#      stop_if_not(is.null(stdout_file), length(conditions) == 0L)
      current_progressor_uuid <<- progressor_uuid
      if (debug) message(" - reset progression handlers")
      update_calling_handler()
      if (!is.null(calling_handler)) {      
        stdout_file <<- delay_stdout(delays, stdout_file = stdout_file)
        calling_handler(control_progression("reset"))
        if (debug) message(" - initiate progression handlers")
        finished <- calling_handler(progression)
        if (debug) message(" - finished: ", finished)
        if (finished) {
          finished <- finish(debug = debug)
          stop_if_not(length(conditions) == 0L, is.na(capture_conditions), isTRUE(finished))
        }
      }
    } else if (type == "update") {
      if (is.null(current_progressor_uuid)) {
        warn_about_too_many_progressions(progression, global = TRUE)
        return()
      }

      if (debug) message(" - update progression handlers")
      if (!is.null(calling_handler)) {
        stdout_file <<- delay_stdout(delays, stdout_file = stdout_file)
        finished <- calling_handler(progression)
        if (debug) message(" - finished: ", finished)
        if (finished) {
          calling_handler(control_progression("shutdown"))
          finished <- finish(debug = debug)
          stop_if_not(length(conditions) == 0L, is.na(capture_conditions), isTRUE(finished))
        }
      }
    } else if (type == "finish") {
      finished <- finish(debug = debug)
      stop_if_not(length(conditions) == 0L, is.na(capture_conditions), isTRUE(finished))
    } else if (type == "status") {
      status <- list(
        current_progressor_uuid = current_progressor_uuid,
        calling_handler = calling_handler,
        delays = delays,
        stdout_file = stdout_file,
        capture_conditions = last_capture_conditions,
        conditions = conditions
      )
      if (debug) message(" - done")
      return(status)
    }

    if (debug) message(" - done")
  } ## handle_progression()


  function(condition) {
    if (is.logical(condition)) {
      stop_if_not(length(condition) == 1L, !is.na(condition))
      active <<- condition
      return()
    }
    
    if (!active) return()
    
    debug <- getOption("progressr.global.debug", FALSE)
    
    ## Shut down progression handling?
    if (inherits(condition, c("interrupt", "error"))) {
      if (isTRUE(getOption("progressr.interrupts", TRUE))) {
        ## Create progress message saying why the progress was interrupted
        msg <- sprintf("Progress interrupted by %s condition", class(condition)[1])
        msg <- paste(c(msg, conditionMessage(condition)), collapse = ": ")
        suspendInterrupts({
          interrupt_calling_handler(control_progression("interrupt", message = msg), debug = debug)
        })
      }

      suspendInterrupts({
        progression <- control_progression("shutdown")
        finished <- finish(debug = debug)
        stop_if_not(length(conditions) == 0L, is.na(capture_conditions), isTRUE(finished))
      })
      return()
    }

    ## A 'progression' update?
    if (inherits(condition, "progression")) {
      suspendInterrupts({
        res <- handle_progression(condition, debug = debug)
      })
      return(res)
    }

    ## Nothing do to?
    if (is.na(capture_conditions) || !isTRUE(capture_conditions)) return()

    ## Nothing do to?
    if (is.null(delays) || !inherits(condition, delays$conditions)) return()

    ## Record non-progression condition to be flushed later
    conditions[[length(conditions) + 1L]] <<- condition
    
    ## Muffle it for now
    if (inherits(condition, "message")) {
      tryInvokeRestart("muffleMessage")
    } else if (inherits(condition, "warning")) {
      tryInvokeRestart("muffleWarning")
    } else if (inherits(condition, "condition")) {
      ## If there is a "muffle" restart for this condition,
      ## then invoke that restart, i.e. "muffle" the condition
      restarts <- computeRestarts(condition)
      for (restart in restarts) {
        name <- restart$name
        if (is.null(name)) next
        if (!grepl("^muffle", name)) next
        tryInvokeRestart(restart)
        break
      }
    }
  }
}) ## global_progression_handler()



if (getRversion() < "4.0.0") {
  globalCallingHandlers <- function(...) {
    stop("register_global_progression_handler() requires R (>= 4.0.0)")
  }
}


as_progression_handler <- function(handlers, drop = TRUE, debug = FALSE) {
  ## FIXME(?)
  if (!is.list(handlers)) handlers <- list(handlers)

  if (debug) {
    message("as_progression_handler() ...")
    message(sprintf("- Number of progression handlers: %d", length(handlers)))
    on.exit({
      message(sprintf("- Number of progression handlers: %d", length(handlers)))
      message("as_progression_handler() ... done")
    })
  }

  for (kk in seq_along(handlers)) {
    handler <- handlers[[kk]]
    stop_if_not(is.function(handler))
    if (!inherits(handler, "progression_handler")) {
      if (debug) message(sprintf("- Handler %d is a function; calling it", kk))
      handler <- handler()
      stop_if_not(is.function(handler),
                  inherits(handler, "progression_handler"))
      handlers[[kk]] <- handler
    }
  }

  ## Keep only enabled handlers?
  if (drop) {
    if (debug) message(sprintf("- drop = TRUE => dropping non-enabled handlers"))
    enabled <- vapply(handlers, FUN = function(h) {
      env <- environment(h)
      value <- env$enable
      isTRUE(value) || is.null(value)
    }, FUN.VALUE = TRUE)
    
    if (debug && !all(enabled)) {
      message(sprintf("- Detected %d non-enabled handlers: %s", sum(!enabled), vapply(handlers[!enabled], FUN = function(h) class(h)[1], FUN.VALUE = NA_character_)))
    }
    
    handlers <- handlers[enabled]
  }

  handlers
}
