R/external_highlight.R

In highlight: Syntax Highlighter

highlight_supported_languages <- function() {
  files <- list.files(
    system.file("highlight", "langDefs", package = "highlight"),
    pattern = "lang$"
  )
  gsub("[.]lang$", "", files)
}

#' List of themes supported by external_highlight
#'
#' List of themes supported by \code{\link{external_highlight}}
#'
#' @return A character vector with the names of the themes
#' @export
highlight_themes <- function() {
  files <- list.files(
    system.file("highlight", "themes", package = "highlight"),
    pattern = "style$"
  )
  gsub("[.]style$", "", files)
}

#' List of available output types supported by external_highlight
#'
#' List of available output types supported by \code{\link{external_highlight}}
#'
#' @return A character vector with the list of supported types
#' @export
highlight_output_types <- function() {
  c(
    "HTML",
    "XHTML",
    "TEX",
    "LATEX",
    "RTF",
    "XML",
    "ANSI",
    "XTERM256",
    "HTML32",
    "SVG",
    "BBCODE"
  )
}

highlight_theme <- function(theme = "emacs") {
  if (missing(theme)) {
    theme <- highlight_themes()[1L]
  } else {
    theme <- match.arg(theme, highlight_themes())
  }
  system.file(
    "highlight",
    "themes",
    sprintf("%s.style", theme),
    package = "highlight"
  )
}

highlight_lang <- function(lang = highlight_supported_languages()) {
  if (missing(lang)) {
    stop("no language")
  } else {
    lang <- match.arg(lang, highlight_supported_languages())
  }
  system.file(
    "highlight",
    "langDefs",
    sprintf("%s.lang", lang),
    package = "highlight"
  )
}

highlight_type <- function(type = highlight_output_types()) {
  if (missing(type)) {
    type <- "HTML"
  }
  type <- match.arg(type, highlight_output_types())
  match(type, highlight_output_types()) - 1L
}

#' Multi-language source code highlighter
#'
#' Multi-language source code highlighter
#'
#' @param file Source file to highlight
#' @param outfile Destination of the highlighted code.
#'       When \code{NULL}, the code is simply returned as a character vector
#' @param theme One of the themes. See \code{\link{highlight_themes}} for the list
#'              of available themes.
#' @param lang The language in which the code is to be interpreted. If this argument
#'             is not given, it will be deduced from the file extension.
#' @param type Output format. See \code{\link{highlight_output_types}} for the list
#'             of supported output types.
#' @param line_numbers if \code{TRUE}, the result will include line numbers
#' @param doc if \code{TRUE}, the result is a stand alone document, otherwise, just a
#'            portion to include in a document
#' @param code If given, then the source code is not read from the file
#'
#' @return Nothing if \code{outfile} is given, with the side effect of writing into the file.
#' The result as a character vector if outfile is NULL
#' @seealso \code{\link{highlight}} to highlight R code using the information from the parser
#' @export
external_highlight <- function(
  file,
  outfile = stdout(),
  theme = "kwrite",
  lang = NULL,
  type = "HTML",
  line_numbers = FALSE,
  doc = TRUE,
  code
) {
  if (!missing(code)) {
    file <- sprintf("%s.%s", tempfile(), lang)
    writeLines(code, file)
  }
  type <- highlight_type(type)
  theme <- highlight_theme(theme)

  lang <- highlight_guess_language(file, lang = lang)
  lang <- highlight_lang(lang)

  using_tempfile <- is.null(outfile) || !is.character(outfile)
  output_file <- if (using_tempfile) tempfile() else outfile
  .Call(
    "HighlightMain",
    file,
    output_file,
    type,
    theme,
    lang,
    isTRUE(line_numbers),
    isTRUE(doc),
    PACKAGE = "highlight"
  )
  code <- readLines(output_file)

  w <- which(code == "\\mbox{}")
  code <- code[-tail(w, 1)]
  w <- tail(grep("\\\\\\\\$", code), 1)
  code[w] <- gsub("\\\\\\\\$", "", code[w])

  if (!is.null(outfile)) {
    writeLines(code, outfile)
  }
  invisible(code)
}


highlight_extensions <- function() {
  txt <- readLines(system.file(
    "highlight",
    "filetypes.conf",
    package = "highlight"
  ))

  df <- do.call(
    rbind,
    lapply(grep("^[$]ext", txt, value = TRUE), function(x) {
      extensions <- strsplit(sub("^.*=", "", x), " ")[[1]]
      language <- sub("^.*[(](.*)[)].*$", "\\1", x)

      data.frame(
        lang = rep(language, length(extensions) + 1L),
        ext = c(language, extensions),
        stringsAsFactors = FALSE
      )
    })
  )

  files <- list.files(
    system.file("highlight", "langDefs", package = "highlight"),
    pattern = "[.]lang$"
  )
  languages <- sub("[.]lang$", "", files)

  missings <- setdiff(languages, unique(df$lang))
  df <- rbind(
    df,
    data.frame(lang = missings, ext = missings, stringsAsFactors = FALSE)
  )

  df <- df[order(df$lang), ]
}

highlight_guess_language <- function(file, lang = NULL) {
  if (is.null(lang)) {
    lang <- sub("^.*[.]([^.]*)$", "\\1", file)
  }
  if (lang == "") {
    stop("no extension")
  }

  df <- highlight_extensions()
  id <- match(lang, df$ext)
  if (is.na(id)) {
    stop("unknown extension")
  }

  df[id, "lang"]
}