htmltools: Tools for HTML

#' Process an HTML template
#'
#' Process an HTML template and return a tagList object. If the template is a
#' complete HTML document, then the returned object will also have class
#' \code{html_document}, and can be passed to the function
#' \code{\link{renderDocument}} to get the final HTML text.
#'
#' @param filename Path to an HTML template file. Incompatible with
#'   \code{text_}.
#' @param ... Variable values to use when processing the template.
#' @param text_ A string to use as the template, instead of a file. Incompatible
#'   with \code{filename}.
#' @param document_ Is this template a complete HTML document (\code{TRUE}), or
#'   a fragment of HTML that is to be inserted into an HTML document
#'   (\code{FALSE})? With \code{"auto"} (the default), auto-detect by searching
#'   for the string \code{"<HTML>"} within the template.
#'
#' @seealso \code{\link{renderDocument}}
#' @export
htmlTemplate <- function(filename = NULL, ..., text_ = NULL, document_ = "auto") {
  if (!xor(is.null(filename), is.null(text_))) {
    stop("htmlTemplate requires either `filename` or `text_`.")
  }

  if (!is.null(filename)) {
    html <- readChar(filename, file.info(filename)$size, useBytes = TRUE)
    Encoding(html) <- "UTF-8"
  } else if(!is.null(text_)) {
    text_ <- paste(text_, collapse = "\n")
    html <- enc2utf8(text_)
  }

  pieces <- strsplit(html, "{{", fixed = TRUE)[[1]]
  pieces <- strsplit(pieces, "}}", fixed = TRUE)

  # Each item in `pieces` is a 2-element character vector. In that vector, the
  # first item is code, and the second is text. The one exception is that the
  # first item in `pieces` will be a 1-element char vector; that element is
  # text.
  if (length(pieces[[1]]) != 1) {
    stop("Mismatched {{ and }} in HTML template.")
  }
  lapply(pieces[-1], function(x) {
    if (length(x) != 2) {
      stop("Mismatched {{ and }} in HTML template.")
    }
  })

  # Create environment to evaluate code, as a child of the global env. This
  # environment gets the ... arguments assigned as variables.
  vars <- list(...)
  if ("headContent" %in% names(vars)) {
    stop("Can't use reserved argument name 'headContent'.")
  }
  vars$headContent <- function() HTML("<!-- HEAD_CONTENT -->")
  env <- list2env(vars, parent = globalenv())

  pieces[[1]] <- HTML(pieces[[1]])
  # For each item in `pieces` other than the first, run the code in the first subitem.
  pieces[-1] <- lapply(pieces[-1], function(piece) {
    tagList(
      eval(parse(text = piece[1]), env),
      HTML(piece[[2]])
    )
  })

  result <- tagList(pieces)

  if (document_ == "auto") {
    document_ = grepl("<HTML>", html, ignore.case = TRUE)
  }
  if (document_) {
    # The html.document class indicates that it's a complete document, and not
    # just a set of tags.
    class(result) <- c("html_document", class(result))
  }

  result
}


#' Render an html_document object
#'
#' This function renders \code{html_document} objects, and returns a string with
#' the final HTML content. It calls the \code{\link{renderTags}} function to
#' convert any shiny.tag objects to HTML. It also finds any any web dependencies
#' (created by \code{\link{htmlDependency}}) that are attached to the tags, and
#' inserts those. To do the insertion, this function finds the string
#' \code{"<!-- HEAD_CONTENT -->"} in the document, and replaces it with the web
#' dependencies.
#'
#' @param x An object of class \code{html_document}, typically generated by the
#'   \code{\link{htmlTemplate}} function.
#' @param deps Any extra web dependencies to add to the html document. This can
#'   be an object created by \code{\link{htmlDependency}}, or a list of such
#'   objects. These dependencies will be added first, before other dependencies.
#' @param processDep A function that takes a "raw" html_dependency object and
#'   does further processing on it. For example, when \code{renderDocument} is
#'   called from Shiny, the function \code{\link[shiny]{createWebDependency}} is
#'   used; it modifies the href and tells Shiny to serve a particular path on
#'   the filesystem.
#'
#' @export
renderDocument <- function(x, deps = NULL, processDep = identity) {
  if (!inherits(x, "html_document")) {
    stop("Object must be an object of class html_document")
  }
  if (inherits(deps, "html_dependency")) {
    deps <- list(deps)
  }

  result <- renderTags(x)

  # Figure out dependencies
  deps <- c(deps, result$dependencies)
  deps <- resolveDependencies(deps)
  deps <- lapply(deps, processDep)
  depStr <- paste(sapply(deps, function(dep) {
    sprintf("%s[%s]", dep$name, dep$version)
  }), collapse = ";")
  depHtml <- renderDependencies(deps, "href")

  # Put content in the <head> section
  head_content <- paste0(
    '  <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>',
    sprintf('  <script type="application/shiny-singletons">%s</script>',
            paste(result$singletons, collapse = ',')
    ),
    sprintf('  <script type="application/html-dependencies">%s</script>',
            depStr
    ),
    depHtml,
    c(result$head, recursive = TRUE)
  )
  sub("<!-- HEAD_CONTENT -->", head_content, result$html, fixed = TRUE)
}