htmltools: Tools for HTML

Documented in htmlTemplate renderDocument

#' 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
#' `html_document`, and can be passed to the function
#' [renderDocument()] to get the final HTML text.
#'
#' @param filename Path to an HTML template file. Incompatible with
#'   `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 `filename`.
#' @param document_ Is this template a complete HTML document (`TRUE`), or
#'   a fragment of HTML that is to be inserted into an HTML document
#'   (`FALSE`)? With `"auto"` (the default), auto-detect by searching
#'   for the string `"<HTML>"` within the template.
#'
#' @seealso [renderDocument()]
#' @export
#' @useDynLib htmltools, .registration = TRUE
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_ <- paste8(text_, collapse = "\n")
    html <- enc2utf8(text_)
  }

  pieces <- .Call(template_dfa, html)
  Encoding(pieces) <- "UTF-8"

  # Create environment to evaluate code, as a child of the global env. This
  # environment gets the ... arguments assigned as variables.
  vars <- dots_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())

  # All the odd-numbered pieces are HTML; all the even-numbered pieces are code
  pieces <- mapply(
    pieces,
    rep_len(c(FALSE, TRUE), length.out = length(pieces)),
    FUN = function(piece, isCode) {
      if (isCode) {
        eval(parse(text = piece), env)
      } else {
        HTML(piece, .noWS = "outside")
      }
    },
    SIMPLIFY = FALSE
  )


  result <- tagList(pieces)

  if (document_ == "auto") {
    document_ = grepl("<HTML(\\s[^<]*)?>", 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 `html_document` objects, and returns a string with
#' the final HTML content. It calls the [renderTags()] function to
#' convert any shiny.tag objects to HTML. It also finds any any web dependencies
#' (created by [htmlDependency()]) that are attached to the tags, and
#' inserts those. To do the insertion, this function finds the string
#' `"<!-- HEAD_CONTENT -->"` in the document, and replaces it with the web
#' dependencies.
#'
#' @param x An object of class `html_document`, typically generated by the
#'   [htmlTemplate()] function.
#' @param deps Any extra web dependencies to add to the html document. This can
#'   be an object created by [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 `renderDocument` is
#'   called from Shiny, the function [shiny::createWebDependency()] is
#'   used; it modifies the href and tells Shiny to serve a particular path on
#'   the filesystem.
#'
#' @return An [HTML()] string, with UTF-8 encoding.
#'
#' @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"/>\n',
    sprintf('  <script type="application/shiny-singletons">%s</script>\n',
            paste(result$singletons, collapse = ',')
    ),
    sprintf('  <script type="application/html-dependencies">%s</script>\n',
            depStr
    ),
    depHtml,
    c(result$head, recursive = TRUE)
  )
  # Need to mark result as UTF-8. If body is ASCII, it will be marked with
  # encoding "unknown". If the head has UTF-8 characters and is marked as
  # "UTF-8", the output string here will have the correct UTF-8 byte sequences,
  # but will be marked as "unknown", which causes the wrong text to be
  # displayed. See https://github.com/rstudio/shiny/issues/1395
  res <- sub("<!-- HEAD_CONTENT -->", head_content, result$html, fixed = TRUE)
  Encoding(res) <- "UTF-8"
  res
}