#' Define an R Markdown output format
#'
#' Define an R Markdown output format based on a combination of knitr and pandoc
#' options.
#'
#' @param knitr Knitr options for an output format (see
#'   \code{\link{knitr_options}})
#' @param pandoc Pandoc options for an output format (see
#'   \code{\link{pandoc_options}})
#' @param keep_md Keep the markdown file generated by knitting. Note that
#'   if this is \code{TRUE} then \code{clean_supporting} will always be
#'   \code{FALSE}.
#' @param clean_supporting Cleanup any supporting files after conversion see
#'   \code{\link{render_supporting_files}}
#' @param df_print Method to be used for printing data frames. Valid values
#'   include "default", "kable", "tibble", and "paged". The "default" method uses
#'   \code{print.data.frame}. The "kable" method uses the
#'   \code{\link[knitr:kable]{knitr::kable}} function. The "tibble" method uses
#'   the \pkg{tibble} package to print a summary of the data frame. The "paged"
#'   method creates a paginated HTML table (note that this method is only valid
#'   for formats that produce HTML). In addition
#'   to the named methods you can also pass an arbitrary function to be used
#'   for printing data frames. You can disable the df_print behavior entirely
#'   by setting the option \code{rmarkdown.df_print} to \code{FALSE}.
#' @param pre_knit An optional function that runs before kniting which
#'   receives the \code{input} (input filename passed to \code{render}) and
#'   \code{...} (for future expansion) arguments.
#' @param post_knit An optional function that runs after kniting which
#'   receives the \code{metadata}, \code{input_file}, \code{runtime}, and \code{...}
#'   (for future expansion) arguments. This function can return additional
#'   arguments to pass to pandoc and can call \code{knitr::knit_meta_add}
#'   to add additional dependencies based on the contents of the input_file or on other
#'   assets side by side with it that may be used to produce html with dependencies
#'   during subsequent processing.
#' @param pre_processor An optional pre-processor function that receives the
#'   \code{metadata}, \code{input_file}, \code{runtime}, \code{knit_meta},
#'   \code{files_dir}, and \code{output_dir} and can return additional arguments
#'   to pass to pandoc.
#' @param intermediates_generator An optional function that receives the
#'   original \code{input_file}, its \code{encoding}, and the intermediates
#'   directory (i.e. the \code{intermediates_dir} argument to
#'   \code{\link{render}}). The function should generate and return the names of
#'   any intermediate files required to render the \code{input_file}.
#' @param post_processor An optional post-processor function that receives the
#'   \code{metadata}, \code{input_file}, \code{output_file}, \code{clean},
#'   and \code{verbose} parameters, and can return an alternative
#'   \code{output_file}.
#' @param on_exit A function to call when \code{rmarkdown::render()} finishes
#'   execution (as registered with a \code{\link{on.exit}} handler).
#' @param base_format An optional format to extend.
#'
#' @return An R Markdown output format definition that can be passed to
#'   \code{\link{render}}.
#'
#' @seealso \link{render}, \link{knitr_options}, \link{pandoc_options}
#'
#' @examples
#' \dontrun{
#' output_format(knitr = knitr_options(opts_chunk = list(dev = 'png')),
#'               pandoc = pandoc_options(to = "html"))
#' }
#'
#' @export
output_format <- function(knitr,
                          pandoc,
                          keep_md = FALSE,
                          clean_supporting = TRUE,
                          df_print = NULL,
                          pre_knit = NULL,
                          post_knit = NULL,
                          pre_processor = NULL,
                          intermediates_generator = NULL,
                          post_processor = NULL,
                          on_exit = NULL,
                          base_format = NULL) {

  format <- list(
    knitr = knitr,
    pandoc = pandoc,
    keep_md = keep_md,
    clean_supporting = clean_supporting && !keep_md,
    df_print = df_print,
    pre_knit = pre_knit,
    post_knit = post_knit,
    pre_processor = pre_processor,
    intermediates_generator = intermediates_generator,
    post_processor = post_processor,
    on_exit = on_exit
  )

  class(format) <- "rmarkdown_output_format"

  # if a base format was supplied, merge it with the format we just created
  if (!is.null(base_format))
    merge_output_formats(base_format, format)
  else
    format
}

# merges two scalar values; picks the overlay if non-NULL and then the base
merge_scalar <- function(base, overlay) {
  if (is.null(base) && is.null(overlay))
    NULL
  else if (is.null(overlay))
    base
  else
    overlay
}

# merges two functions: if both are non-NULL, produces a new function that
# invokes each and then uses the supplied operation to combine their outputs
merge_function_outputs <- function(base, overlay, op) {
  if (!is.null(base) && !is.null(overlay)) {
    function(...) {
      op(base(...), overlay(...))
    }
  } else {
    merge_scalar(base, overlay)
  }
}

# merges two post-processors; if both are non-NULL, produces a new function that
# calls the overlay post-processor and then the base post-processor.
merge_post_processors <- function(base, overlay) {
  if (!is.null(base) && !is.null(overlay)) {
    function(metadata, input_file, output_file, ...) {
      output_file <- overlay(metadata, input_file, output_file, ...)
      base(metadata, input_file, output_file, ...)
    }
  }
  else {
    merge_scalar(base, overlay)
  }
}

# merges two output formats
merge_output_formats <- function(base, overlay)  {
  structure(list(
    knitr = merge_lists(base$knitr, overlay$knitr),
    pandoc = merge_pandoc_options(base$pandoc, overlay$pandoc),
    keep_md =
      merge_scalar(base$keep_md, overlay$keep_md),
    clean_supporting =
      merge_scalar(base$clean_supporting, overlay$clean_supporting),
    df_print =
      merge_scalar(base$df_print, overlay$df_print),
    pre_knit =
      merge_function_outputs(base$pre_knit, overlay$pre_knit, c),
    post_knit =
      merge_function_outputs(base$post_knit, overlay$post_knit, c),
    pre_processor =
      merge_function_outputs(base$pre_processor, overlay$pre_processor, c),
    intermediates_generator =
      merge_function_outputs(base$intermediates_generator,
                             overlay$intermediates_generator, c),
    post_processor =
      merge_post_processors(base$post_processor, overlay$post_processor),
    on_exit =
      merge_on_exit(base$on_exit, overlay$on_exit)
  ), class = "rmarkdown_output_format")
}

merge_on_exit <- function(base, overlay) {
  function() {
    if (is.function(base)) base()
    if (is.function(overlay)) overlay()
  }
}

merge_pandoc_options <- function(base, overlay) {
  res <- merge_lists(base, overlay, recursive = FALSE)
  res$args <- c(base$args, overlay$args)
  res
}

#' Knitr options for an output format
#'
#' Define the knitr options for an R Markdown output format.
#'
#' @param opts_knit List of package level knitr options (see
#'   \code{\link[knitr:opts_knit]{opts_knit}})
#' @param opts_chunk List of chunk level knitr options (see
#'   \code{\link[knitr:opts_chunk]{opts_chunk}})
#' @param knit_hooks List of hooks for R code chunks, inline R code, and output
#'   (see \code{\link[knitr:knit_hooks]{knit_hooks}})
#' @param opts_hooks List of hooks for code chunk options
#'   (see \code{\link[knitr:opts_hooks]{opts_hooks}})
#' @param opts_template List of templates for chunk level knitr options (see
#'   \code{\link[knitr:opts_template]{opts_template}})
#'
#' @return An list that can be passed as the \code{knitr} argument of the
#'   \code{\link{output_format}} function.
#'
#' @seealso \link{output_format}
#'
#' @export
knitr_options <- function(opts_knit = NULL,
                          opts_chunk = NULL,
                          knit_hooks = NULL,
                          opts_hooks = NULL,
                          opts_template = NULL) {
  list(opts_knit = opts_knit,
       opts_chunk = opts_chunk,
       knit_hooks = knit_hooks,
       opts_hooks = opts_hooks,
       opts_template = opts_template)
}

#' Knitr options for a PDF output format
#'
#' Define knitr options for an R Markdown output format that creates PDF output.
#'
#' @inheritParams html_document
#' @inheritParams pdf_document
#'
#' @return An list that can be passed as the \code{knitr} argument of the
#'   \code{\link{output_format}} function.
#'
#' @seealso \link{knitr_options}, \link{output_format}
#'
#' @export
knitr_options_pdf <- function(fig_width, fig_height, fig_crop, dev = 'pdf') {

  # default options
  opts_knit <- NULL
  opts_chunk <- list(dev = dev,
                     fig.width = fig_width,
                     fig.height = fig_height)

  # set the dingbats option for the pdf device if required
  if (dev == 'pdf')
    opts_chunk$dev.args <- list(pdf = list(useDingbats = FALSE))

  knit_hooks <- NULL

  # apply cropping if requested and we have pdfcrop
  crop <- fig_crop && !is_windows() && nzchar(find_program("pdfcrop"))
  if (crop) {
    knit_hooks = list(crop = knitr::hook_pdfcrop)
    opts_chunk$crop = TRUE
  }

  # return options
  knitr_options(opts_knit = opts_knit,
                opts_chunk = opts_chunk,
                knit_hooks = knit_hooks)
}


#' Pandoc options for an output format
#'
#' Define the pandoc options for an R Markdown output format.
#'
#' @param to Pandoc format to convert to
#' @param from Pandoc format to convert from
#' @param args Character vector of command line arguments to pass to pandoc
#' @param keep_tex Keep the intermediate tex file used in the conversion to PDF
#'   (applies only to 'latex' and 'beamer' target formats)
#' @param latex_engine LaTeX engine to producing PDF output (applies only to
#'   'latex' and 'beamer' target formats)
#' @param ext File extension (e.g. ".tex") for output file (if \code{NULL}
#'   chooses default based on \code{to}). This is typically used to force
#'   the final output of a latex or beamer conversion to be \code{.tex}
#'   rather than \code{.pdf}.
#'
#' @return An list that can be passed as the \code{pandoc} argument of the
#'   \code{\link{output_format}} function.
#'
#' @details The \code{from} argument should be used very cautiously as it's
#'   important for users to be able to rely on a stable definition of supported
#'   markdown extensions.
#'
#' @seealso \link{output_format}, \link{rmarkdown_format}
#'
#' @export
pandoc_options <- function(to,
                           from = rmarkdown_format(),
                           args = NULL,
                           keep_tex = FALSE,
                           latex_engine = c("pdflatex", "lualatex", "xelatex"),
                           ext = NULL) {
  list(to = to,
       from = from,
       args = args,
       keep_tex = keep_tex,
       latex_engine = match.arg(latex_engine),
       ext = ext)
}

#' R Markdown input format definition
#'
#' Compose a pandoc markdown input definition for R Markdown that can be
#' passed as the \code{from} argument of \link{pandoc_options}.
#'
#'
#' @param implicit_figures Automatically make figures from images (defaults to \code{TRUE}).
#' @param extensions Markdown extensions to be added or removed from the
#' default definition of R Markdown.
#'
#' @return Pandoc markdown format specification
#'
#' @details
#'
#' By default R Markdown is defined as all pandoc markdown extensions with
#' the following tweaks for backward compatibility with the markdown package
#' (+ features are added, - features are removed):
#'
#' \tabular{l}{
#' \code{+autolink_bare_uris} \cr
#' \code{+ascii_identifier} \cr
#' \code{+tex_math_single_backslash} \cr
#' }
#'
#'
#' For more on pandoc markdown see the \href{http://pandoc.org/README.html}{pandoc online documentation}.
#'
#' @examples
#' \dontrun{
#' rmarkdown_format("-implicit_figures")
#' }
#'
#' @seealso \link{output_format}, \link{pandoc_options}
#'
#' @export
rmarkdown_format <- function(extensions = NULL) {

  format <- c("markdown")

  # only add extensions if the user hasn't already specified
  # a manual override for them
  addExtension <- function(extension) {
    if (length(grep(extension, extensions)) == 0)
      format <<- c(format, paste0("+", extension))
  }

  addExtension("autolink_bare_uris")
  addExtension("ascii_identifiers")
  addExtension("tex_math_single_backslash")

  format <- c(format, extensions, recursive = TRUE)

  paste(format, collapse = "")
}

# Add the +smart extension for Pandoc >= 2.0
smart_extension <- function(smart, extension) {
  c(extension, if (smart && pandoc2.0()) "+smart")
}

#' Determine the default output format for an R Markdown document
#'
#' Read the YAML metadata (and any common _output.yml file) for the
#' document and return the output format that will be generated by
#' a call to \code{\link{render}}.
#'
#' @param input Input file (Rmd or plain markdown)
#' @param encoding The encoding of the input file; see \code{\link{file}}
#'
#' @return A named list with a \code{name} value containing the format
#'   name and an \code{options} value that is a list containing all the options
#'   for the format and their values. An option's default value will be returned
#'   if the option isn't set explicitly in the document.
#'
#' @details
#'
#' This function is useful for front-end tools that require additional
#' knowledge of the output to be produced by \code{\link{render}} (e.g. to
#' customize the preview experience).
#'
#' @export
default_output_format <- function(input, encoding = getOption("encoding")) {

  # execute within the input file's directory (this emulates the way
  # yaml front matter discovery is done within render)
  oldwd <- setwd(dirname(tools::file_path_as_absolute(input)))
  on.exit(setwd(oldwd), add = TRUE)

  # because we're now within the same directory as the input file,
  # we just need its basename
  input <- basename(input)

  # parse the YAML and front matter and get the explicitly set options
  input_lines <- read_lines_utf8(input, encoding)
  format <- output_format_from_yaml_front_matter(input_lines, encoding = encoding)

  # look up the formals of the output function to get the full option list and
  # merge against the explicitly set list
  format_function <- eval(parse(text = format$name))
  format$options <- merge_lists(as.list(formals(format_function)),
                                format$options,
                                recursive = FALSE)
  format
}

#' Resolve the output format for an R Markdown document
#'
#' Read the YAML metadata (and any common _output.yml file) for the
#' document and return an output format object that can be
#' passed to the \code{\link{render}} function.
#'
#' @param input Input file (Rmd or plain markdown)
#' @param output_format Name of output format (or \code{NULL} to use
#'   the default format for the input file).
#' @param output_options List of output options that should override the
#'   options specified in metadata.
#' @param encoding The encoding of the input file; see \code{\link{file}}
#'
#' @return An R Markdown output format definition that can be passed to
#'   \code{\link{render}}.
#'
#' @details
#'
#' This function is useful for front-end tools that need to modify
#' the default behavior of an output format.
#'
#' @export
resolve_output_format <- function(input,
                                  output_format = NULL,
                                  output_options = NULL,
                                  encoding = getOption("encoding")) {

  # read the input file
  input_lines <- read_lines_utf8(input, encoding)

  # validate that the output format is either NULL or a character vector
  if (!is.null(output_format) && !is.character(output_format))
    stop("output_format must be a character vector")

  # resolve the output format by looking at the yaml
  output_format <- output_format_from_yaml_front_matter(input_lines,
                                                        output_options,
                                                        output_format,
                                                        encoding = encoding)

  # return it
  create_output_format(output_format$name, output_format$options)
}


#' Determine all output formats for an R Markdown document
#'
#' Read the YAML metadata (and any common _output.yml file) for the
#' document and return the output formats that will be generated by
#' a call to \code{\link{render}}.
#'
#' @param input Input file (Rmd or plain markdown)
#' @param encoding The encoding of the input file; see \code{\link{file}}
#'
#' @return A character vector with the names of all output formats.
#'
#' @details
#'
#' This function is useful for front-end tools that require additional
#' knowledge of the output to be produced by \code{\link{render}} (e.g. to
#' customize the preview experience).
#'
#' @export
all_output_formats <- function(input, encoding = getOption("encoding")) {
  enumerate_output_formats(input = input,
                           envir = parent.frame(),
                           encoding = encoding)

}


# Synthesize the output format for a document from it's YAML. If we can't
# find an output format then we just return html_document
output_format_from_yaml_front_matter <- function(input_lines,
                                                 output_options = NULL,
                                                 output_format_name = NULL,
                                                 encoding = getOption("encoding")) {

  format_name <- output_format_name
  # ensure input is the correct data type
  if (!is_null_or_string(format_name)) {
    stop("Unrecognized output format specified", call. = FALSE)
  }

  # parse the yaml
  yaml_input <- parse_yaml_front_matter(input_lines)

  # default to no options
  format_options <- list()

  # parse _site.yml output format if we have it
  config <- site_config(".", encoding = encoding)
  yaml_site <- config[["output"]]

  # parse common _output.yml if we have it
  yaml_common <- if (file.exists("_output.yml")) {
    yaml_load_file_utf8("_output.yml")
  } else if (file.exists("_output.yaml")) {
    yaml_load_file_utf8("_output.yaml")
  }

  # merge _site.yml and _output.yml
  yaml_common <- merge_output_options(yaml_site, yaml_common)

  # parse output format from front-matter if we have it
  if (length(yaml_common) || length(yaml_input[["output"]])) {

    # alias the output format yaml
    yaml_output <- yaml_input[["output"]]

    # merge against common _output.yml
    yaml_output <- merge_output_options(yaml_common, yaml_output)

    # if a named format was provided then try to find it
    if (!is.null(format_name)) {

      # if this is a named element of the list then use that
      if (format_name %in% names(yaml_output)) {

        format_options <- yaml_output[[format_name]]

      # otherwise this could be a heterogeneous list of characters and
      # lists so scan for an embedded list
      } else {
        for (format in yaml_output) {
          if (is.list(format) && !is.null(format[[format_name]]))
            format_options <- format[[format_name]]
        }
      }

      # if the options are just "default" then that's the same as empty list
      if (identical(format_options, "default")) format_options <- list()

    # no named format passed so take the first element
    } else {
      if (is.list(yaml_output[[1]])) {
        # check for named list
        if (nzchar(format_name <- names(yaml_output)[[1]])) {
          format_options <- yaml_output[[1]]
        # nested named list
        } else {
          format_name <- names(yaml_output[[1]])[[1]]
          format_options <- yaml_output[[1]][[format_name]]
        }
      } else if (is.list(yaml_output) &&
                   (is.null(yaml_output[[1]]) ||
                      identical(yaml_output[[1]], "default"))) {
        format_name <- names(yaml_output)[[1]]

      } else {
        format_name <- yaml_output[[1]]
      }
    }

  # no output formats defined in the file, just take the passed format
  # by name (or default to html_document if no named format was specified)
  } else {
    if (is.null(format_name)) format_name <- "html_document"
  }

  # merge any output_options passed in the call to render
  if (!is.null(output_options)) {
    format_options <- merge_output_options(format_options, output_options)
  }

  # return the format name and options
  list(name = format_name, options = format_options)
}

create_output_format <- function(name, options) {

  # validate the name
  if (is.null(name))
    stop("The output format name must not be NULL", call. = FALSE)
  if (name == "revealjs_presentation")
    stop("reveal.js presentations are now located in a separate package: ",
         "https://github.com/jjallaire/revealjs")

  # lookup the function
  output_format_func <- eval(parse(text = name))
  if (!is.function(output_format_func))
    stop("YAML output format must evaluate to a function", call. = FALSE)

  # call the function
  output_format <- do.call(output_format_func, options)
  if (!is_output_format(output_format))
    stop("Format is not of class rmarkdown_output_format", call. = FALSE)

  # return the format
  output_format
}

is_output_format <- function(x) {
  inherits(x, "rmarkdown_output_format")
}

enumerate_output_formats <- function(input, envir, encoding) {

  # read the input
  input_lines <- read_lines_utf8(input, encoding)

  # if this is an R file then spin it
  if (identical(tolower(tools::file_ext(input)), "r"))
    input_lines <- knitr::spin(text = input_lines, knit = FALSE, envir = envir)

  # parse _site.yml output format if we have it
  config <- site_config(input, encoding = encoding)
  if (!is.null(config) && !is.null(config[["output"]])) {
    site_output_format_yaml <- config[["output"]]
  } else {
    site_output_format_yaml <- list()
  }

  # read the ymal front matter
  yaml_front_matter <- parse_yaml_front_matter(input_lines)

  # read any _output.yml
  output_yml <- file.path(dirname(input), "_output.yml")
  output_yaml <- file.path(dirname(input), "_output.yaml")
  if (file.exists(output_yml))
    common_output_format_yaml <- yaml_load_file_utf8(output_yml)
  else if (file.exists(output_yaml))
    common_output_format_yaml <- yaml_load_file_utf8(output_yaml)
  else
    common_output_format_yaml <- list()

  # merge site and common
  common_output_format_yaml <- merge_output_options(site_output_format_yaml,
                                                    common_output_format_yaml)

  # parse output formats from front-matter if we have it
  if (length(common_output_format_yaml) > 0 ||
      length(yaml_front_matter[["output"]]) > 0) {

    # alias the output format yaml
    output_format_yaml <- yaml_front_matter[["output"]]

    # merge against common _output.yml
    output_format_yaml <- merge_output_options(common_output_format_yaml,
                                               output_format_yaml)
  }
  else {
    output_format_yaml <- NULL
  }

  # return them by name
  if (is.character(output_format_yaml)) {
    output_format_yaml
  } else if (is.list(output_format_yaml)) {
    names(output_format_yaml)
  } else {
    NULL
  }
}

#' Parse the YAML front matter from a file
#'
#' @inheritParams default_output_format
#'
#' @keywords internal
#' @export
yaml_front_matter <- function(input, encoding = getOption("encoding")) {

   # read the input file
  input_lines <- read_lines_utf8(input, encoding)

  # parse the yaml front matter
  parse_yaml_front_matter(input_lines)
}

parse_yaml_front_matter <- function(input_lines) {

  partitions <- partition_yaml_front_matter(input_lines)
  if (!is.null(partitions$front_matter)) {
    front_matter <- partitions$front_matter
    if (length(front_matter) > 2) {
      front_matter <- front_matter[2:(length(front_matter) - 1)]
      front_matter <- paste(front_matter, collapse = "\n")
      validate_front_matter(front_matter)
      parsed_yaml <- yaml_load_utf8(front_matter)
      if (is.list(parsed_yaml))
        parsed_yaml
      else
        list()
    }
    else
      list()
  }
  else
    list()
}

validate_front_matter <- function(front_matter) {
  front_matter <- trim_trailing_ws(front_matter)
  if (grepl(":$", front_matter))
    stop("Invalid YAML front matter (ends with ':')", call. = FALSE)
}



partition_yaml_front_matter <- function(input_lines) {

  validate_front_matter <- function(delimiters) {
    if (length(delimiters) >= 2 &&
        (delimiters[2] - delimiters[1] > 1) &&
        grepl("^---\\s*$", input_lines[delimiters[1]])) {
      # verify that it's truly front matter (not preceded by other content)
      if (delimiters[1] == 1)
        TRUE
      else
        is_blank(input_lines[1:delimiters[1] - 1])
    } else {
      FALSE
    }
  }

  # is there yaml front matter?
  delimiters <- grep("^(---|\\.\\.\\.)\\s*$", input_lines)
  if (validate_front_matter(delimiters)) {

    front_matter <- input_lines[(delimiters[1]):(delimiters[2])]

    input_body <- c()

    if (delimiters[1] > 1)
      input_body <- c(input_body,
                      input_lines[1:delimiters[1] - 1])

    if (delimiters[2] < length(input_lines))
      input_body <- c(input_body,
                      input_lines[-(1:delimiters[2])])

    list(front_matter = front_matter,
         body = input_body)
  }
  else {
    list(front_matter = NULL,
         body = input_lines)
  }
}

merge_output_options <- function(base_options, overlay_options) {

  # if either one of these is a character vector then normalize to a named list
  normalize_list <- function(target) {
    if (is.null(target)) {
      list()
    } else if (is.character(target)) {
      setNames(lapply(target, function(x) list()), target)
    } else {
      target[names(target) != "..."]  # remove symbols (...) from list
    }
  }

  merge_lists(normalize_list(base_options), normalize_list(overlay_options))
}

is_pandoc_to_html <- function(options) {
  options$to %in% c("html", "html4", "html5")
}

citeproc_required <- function(yaml_front_matter, input_lines = NULL) {
  (
    is.null(yaml_front_matter$citeproc) ||
      yaml_front_matter$citeproc
  ) && (
    !is.null(yaml_front_matter$bibliography) ||
      !is.null(yaml_front_matter$references) ||
      length(grep("^references\\:\\s*$", input_lines)) > 0
  )
}
