#' Create a printer callback function
#'
#' A printer callback function is a function can performs the actual
#' printing. It has a number of subcommands, that are called by
#' the `printer` package, in a form \preformatted{
#'     printer_callback("subcommand", argument1, argument2, ...)
#' } See the examples below.
#'
#' The subcommands:
#'
#' \describe{
#'     \item{`length`}{
#'       The length of the data to print, the number of items, in natural units.
#'       E.g. for a list of objects, it is the number of objects.
#'     }
#'     \item{`min_width`}{
#'       TODO
#'     }
#'     \item{`width`}{
#'       Width of one item, if `no` items will be printed. TODO
#'     }
#'     \item{`print`}{
#'       Argument: `no`. Do the actual printing, print `no` items.
#'     }
#'     \item{`done`}{
#'       TODO
#'     }
#'   }
#'
#' @param fun The function to use as a printer callback function.
#' @family printer callbacks
#' @export

printer_callback <- function(fun) {
  if (!is.function(fun)) {
    warning("'fun' is not a function")
  }
  add_class(fun, "printer_callback")
}

#' Is this a printer callback?
#'
#' @param x An R object.
#' @family printer callbacks
#' @export

is_printer_callback <- function(x) {
  inherits(x, "printer_callback")
}

print_header <- function(header) {
  print_head_foot(header)
}


print_footer <- function(footer) {
  print_head_foot(footer)
}

print_head_foot <- function(head_foot) {
  if (is.function(head_foot)) head_foot() else cat(head_foot)
}

#' Print the only the head of an R object
#'
#' @param x The object to print, or a callback function. See
#'   [printer_callback()] for details.
#' @param max_lines Maximum number of lines to print, *not*
#'   including the header and the footer.
#' @param header The header, if a function, then it will be called,
#'   otherwise printed using `cat`.
#' @param footer The footer, if a function, then it will be called,
#'   otherwise printed using `cat`.
#' @param omitted_footer Footer that is only printed if anything
#'   is omitted from the printout. If a function, then it will be called,
#'   otherwise printed using `cat`.
#' @param ... Extra arguments to pass to `print()`.
#' @return `x`, invisibly.
#'
#' @export

head_print <- function(
  x,
  max_lines = 20,
  header = "",
  footer = "",
  omitted_footer = "",
  ...
) {
  if (is_printer_callback(x)) {
    head_print_callback(x, max_lines, header, footer, omitted_footer, ...)
  } else {
    head_print_object(x, max_lines, header, footer, omitted_footer, ...)
  }
  invisible(x)
}

head_print_object <- function(
  x,
  max_lines,
  header,
  footer,
  omitted_footer,
  print_fun = print,
  ...
) {
  print_header(header)

  cout <- capture.output(print_fun(x, ...))
  cout_no <- min(length(cout), max_lines)
  cat(cout[seq_len(cout_no)], sep = "\n")

  print_footer(footer)

  if (cout_no < length(cout)) {
    print_footer(omitted_footer)
  }

  invisible(c(lines = length(cout), printed = cout_no))
}

#' @importFrom utils tail

head_print_callback <- function(
  x,
  max_lines,
  header,
  footer,
  omitted_footer,
  ...
) {
  ## Header
  print_header(header)

  len <- x("length")
  minw <- x("min_width")
  ow <- getOption("width", 80)

  ## Max number of items we can print. This is an upper bound.
  can_max <- min(floor(ow / minw) * max_lines, len)
  if (can_max == 0) {
    return()
  }

  ## Width of item if we print up to this
  cm <- x("width", no = can_max)

  ## How many rows we need if we print up to a certain point
  no_rows <- ceiling(cm * seq_along(cm) / (ow - 4))

  ## So how many items should we print?
  no <- tail(which(no_rows <= max_lines), 1)
  if (is.null(no) || length(no) < 1 || is.na(no)) {
    no <- can_max
  }

  cat_pern <- function(..., sep = "\n") cat(..., sep = sep)

  ## Format them, and print
  out_lines <- head_print_object(
    x("print", no = no, ...),
    print_fun = cat_pern,
    max_lines = max_lines,
    header = "",
    footer = "",
    omitted_footer = ""
  )

  done_stat <- c(
    tried_items = no,
    tried_lines = out_lines[["lines"]],
    printed_lines = out_lines[["printed"]]
  )

  if (
    done_stat["tried_items"] < len ||
      done_stat["printed_lines"] < done_stat["tried_lines"]
  ) {
    print_footer(omitted_footer)
  }

  x("done", done_stat)

  ## Footer
  print_footer(footer)
}

#' Indent a printout
#'
#' @param ... Passed to the printing function.
#' @param .indent Character scalar, indent the printout with this.
#' @param .printer The printing function, defaults to [print].
#' @return The first element in `...`, invisibly.
#'
#' @export

indent_print <- function(..., .indent = " ", .printer = print) {
  if (length(.indent) != 1 || !is.character(.indent)) {
    indent <- .indent # cli literal cannot start with a dot
    cli::cli_abort(
      "{.arg .indent} must be a character scalar, not {.obj_type_friendly {indent}}."
    )
  }

  opt <- options(width = getOption("width") - nchar(.indent))
  on.exit(options(opt), add = TRUE)

  cout <- capture.output(.printer(...))
  if (length(cout)) {
    cout <- paste0(.indent, cout)
    cat(cout, sep = "\n")
  }

  invisible(list(...)[[1]])
}
