Add a custom syntax highlight file to support new R 4.0 pipe

NAMESPACE

@@ -71,6 +71,7 @@ export(pandoc_metadata_arg)
 export(pandoc_options)
 export(pandoc_path_arg)
 export(pandoc_self_contained_html)
+export(pandoc_syntax_definition_args)
 export(pandoc_template)
 export(pandoc_toc_args)
 export(pandoc_variable_arg)

R/html_document_base.R

@@ -168,23 +168,15 @@ html_document_base <- function(theme = NULL,
     if (identical(math_method, "r-katex") && xfun::pkg_available("katex", "1.4.0")) {
       katex::render_math_in_html(output_file, output = output_file)
     }
-
-    # Other processing ----
-
-    # read the output file
-    output_str <- read_utf8(output_file)
-
-    # TODO: remove this temporary fix after the syntax highlighting problem is
-    # fixed in Pandoc https://github.com/rstudio/bookdown/issues/1157
-    s1 <- '<span class="sc">|</span><span class="er">&gt;</span>'
-    s2 <- '<span class="ot">=</span><span class="er">&gt;</span>'
-
+
     # if there are no preserved chunks to restore and no resource to copy then no
     # post-processing is necessary
-    if ((length(preserved_chunks) == 0 && !isTRUE(copy_resources) && self_contained) &&
-        !length(c(grep(s1, output_str, fixed = TRUE), grep(s2, output_str, fixed = TRUE))))
+    if (length(preserved_chunks) == 0 && !isTRUE(copy_resources) && self_contained)
       return(output_file)
 
+    # read the output file
+    output_str <- read_utf8(output_file)
+
     # if we preserved chunks, restore them
     if (length(preserved_chunks) > 0) {
       # Pandoc adds an empty <p></p> around the IDs of preserved chunks, and we
@@ -222,10 +214,6 @@ html_document_base <- function(theme = NULL,
       output_str <- process_images(output_str, image_relative)
     }
 
-    # fix the issue mentioned in TODO above
-    output_str <- gsub(s1, '<span class="sc">|&gt;</span>', output_str, fixed = TRUE)
-    output_str <- gsub(s2, '<span class="ot">=&gt;</span>', output_str, fixed = TRUE)
-
     write_utf8(output_str, output_file)
 
     output_file

R/pandoc.R

@@ -783,6 +783,13 @@ pandoc_lua_filter_args <- function(lua_files) {
   if (pandoc2.0()) c(rbind("--lua-filter", pandoc_path_arg(lua_files)))
 }
 
+#' @rdname pandoc_args
+#' @param xml_files Character vector of file paths to KDE syntax files. Paths
+#'   will be transformed by \code{\link{pandoc_path_arg}}.
+#' @export
+pandoc_syntax_definition_args <- function(xml_files) {
+  c(rbind("--syntax-definition", pandoc_path_arg(xml_files)))
+}
 
 # quote args if they need it
 quoted <- function(args) {

R/render.R

@@ -891,6 +891,7 @@ render <- function(input,
       input  <- path.expand(input)
       output <- path.expand(output)
 
+      # Tweak Pandoc argument for all formats
       pandoc_args <- output_format$pandoc$args
 
       # if Lua filters are provided, add the command line switch
@@ -899,6 +900,11 @@ render <- function(input,
       }
       pandoc_args <- c(lua_filters, pandoc_args)
 
+      # if pandoc highlighting is used, add the syntax definition file
+      # supporting new pipe operator. Only done for Pandoc 2.15+
+      # TODO: remove when updated upstream
+      pandoc_args <- add_syntax_definition(pandoc_args, pandoc_to)
+
       # in case the output format turns on the --file-scope flag, run its
       # file_scope function to split the input into multiple files
       input_files <- input
@@ -1214,3 +1220,48 @@ file_scope_split <- function(input, fun) {
 
   unlist(input_files)
 }
+
+add_syntax_definition <- function(args, pandoc_to = "html") {
+  if (
+    # do nothing if opt-out
+    xfun::isFALSE(lang <- getOption("rmarkdown.highlighting.xml.add", TRUE)) ||
+    # do not add before Pandoc 2.15 due to issues with xml parsing,
+    !pandoc_available("2.15") ||
+    # do not add if no Pandoc highlighting,
+    detect_pattern("--no-highlight", args) ||
+    # do not add if format does not support highlight
+    !(pandoc_to %in% c("html", "html4", "html5", "revealjs", "slidy",
+                     "latex", "pdf", "beamer",
+                     "epub", "epub3", "docx", "pptx", "odt"))
+  ) {
+    return(args)
+  }
+
+  # default language to add
+  if (!is.character(lang)) lang <- .syntax_highlight_bundled_language()
+  lang <- setdiff(lang, c(
+    # user provided argument
+    .find_syntax_args(args),
+    # is user asking to remove one ?
+    getOption("rmarkdown.highlighting.xml.remove")
+  ))
+
+  # create the CLI flags
+  c(args,
+    pandoc_syntax_definition_args(
+      pkg_file_highlight(xfun::with_ext(lang, "xml"))
+    )
+  )
+}
+
+.syntax_highlight_bundled_language <- function() {
+  xfun::sans_ext(list.files(pkg_file_highlight(), pattern = "[.]xml$"))
+}
+
+.find_syntax_args <- function(args) {
+  if (!detect_pattern("--syntax-definition", args)) return(character(0))
+  default_lang <- .syntax_highlight_bundled_language()
+  xml_pattern <- sprintf("%s[.]xml", default_lang)
+  found <- vapply(xml_pattern, detect_pattern, vec = args, FUN.VALUE = logical(1))
+  default_lang[found]
+}

R/util.R

@@ -89,8 +89,8 @@ pkg_file_lua <- function(filters = NULL, package = "rmarkdown") {
   pandoc_path_arg(files)
 }
 
-pkg_file_highlight <- function(file) {
-  pkg_file("rmarkdown", "highlight", file, mustWork = TRUE)
+pkg_file_highlight <- function(...) {
+  pkg_file("rmarkdown", "highlight", ..., mustWork = TRUE)
 }
 
 #' @rdname rmarkdown_format
@@ -502,6 +502,10 @@ join <- function(..., sep = "", collapse = "") {
   paste(..., sep = sep, collapse = collapse)
 }
 
+detect_pattern <- function(pattern, vec, ...) {
+  any(grepl(pattern, vec, ...))
+}
+
 shell_exec <- function(cmd, intern = FALSE, wait = TRUE, ...) {
   if (Sys.info()[["sysname"]] == "Windows")
     shell(cmd, intern = intern, wait = wait, ...)