with class sourceCode + R, as created by ```R
+ div_sourceCode_r <- div_sourceCode[has_class(div_sourceCode, "r")]
+ purrr::walk(div_sourceCode_r, tweak_highlight_r)
+
+ # 3)
with class sourceCode + another language, e.g. ```yaml
+ div_sourceCode_other <- div_sourceCode[!has_class(div_sourceCode, "r")]
+ purrr::walk(div_sourceCode_other, tweak_highlight_other)
+
+ invisible()
+}
+
+tweak_highlight_r <- function(block) {
+ code <- xml2::xml_find_first(block, ".//code")
+ if (is.na(code)) {
+ return(FALSE)
+ }
+
+ text <- xml2::xml_text(code)
+ out <- downlit::highlight(text, classes = downlit::classes_pandoc())
+ if (is.na(out) || identical(out, "")) {
+ return(FALSE)
+ }
+
+ html <- xml2::read_html(out)
+ xml_replace_contents(code, xml2::xml_find_first(html, "body"))
+
+ TRUE
+}
+
+tweak_highlight_other <- function(div) {
+ code <- xml2::xml_find_first(div, ".//code")
+ if (is.na(code)) {
+ return(FALSE)
+ }
+
+ lang <- sub("sourceCode ", "", xml2::xml_attr(div, "class"))
+ md <- paste0("```", lang, "\n", xml2::xml_text(code), "\n```")
+ html <- markdown_text(md)
+
+ xml_replace_contents(code, xml2::xml_find_first(html, "body/div/pre/code"))
+ TRUE
+}
+
+xml_replace_contents <- function(node, new) {
+ xml2::xml_remove(xml2::xml_contents(node))
+
+ contents <- xml2::xml_contents(new)
+ for (child in contents) {
+ xml2::xml_add_child(node, child)
+ }
+}
diff --git a/man/render_page.Rd b/man/render_page.Rd
index 22b1622b1..1a6c0738c 100644
--- a/man/render_page.Rd
+++ b/man/render_page.Rd
@@ -1,11 +1,19 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/render.R
+% Please edit documentation in R/render.r
\name{render_page}
\alias{render_page}
\alias{data_template}
\title{Render page with template}
\usage{
-render_page(pkg = ".", name, data, path = "", depth = NULL, quiet = FALSE)
+render_page(
+ pkg = ".",
+ name,
+ data,
+ path = "",
+ depth = NULL,
+ quiet = FALSE,
+ tweaks = NULL
+)
data_template(pkg = ".", depth = 0L)
}
@@ -31,6 +39,8 @@ If \code{""} (the default), prints to standard out.}
\item{depth}{Depth of path relative to base directory.}
\item{quiet}{If \code{quiet}, will suppress output messages}
+
+\item{tweaks}{List of "tweak" functions applied to output HTML.}
}
\description{
Each page is composed of four templates: "head", "header", "content", and
diff --git a/man/test-verbatim.Rd b/man/test-verbatim.Rd
index 2843bb2b6..49162652e 100644
--- a/man/test-verbatim.Rd
+++ b/man/test-verbatim.Rd
@@ -2,7 +2,7 @@
% Please edit documentation in R/test.R
\name{test-verbatim}
\alias{test-verbatim}
-\title{Test case: verbatim blocks}
+\title{Test case: preformatted blocks & syntax highlighting}
\description{
This description block is required so that verbatim blocks are recognized
and rendered correctly.
@@ -19,6 +19,15 @@ OR:
yaml:
that
}
+
+And this block should get syntax highlighting:\if{html}{\out{
}}\preformatted{yaml:
+ this
+
+OR:
+
+yaml:
+ that
+}\if{html}{\out{
}}
}
\seealso{
Other tests:
diff --git a/tests/testthat/test-rd-html.R b/tests/testthat/test-rd-html.R
index e324c1faf..206eabd62 100644
--- a/tests/testthat/test-rd-html.R
+++ b/tests/testthat/test-rd-html.R
@@ -367,15 +367,7 @@ test_that("nested item with whitespace parsed correctly", {
# Verbatim ----------------------------------------------------------------
-# test_that("parseable preformatted blocks are highlighted", {
-# out <- flatten_para(rd_text("\\preformatted{1}"))
-# expect_equal(out, "
1
\n")
-#
-# out <- flatten_para(rd_text("\\preformatted{1 > 2}"))
-# expect_equal(out, "
1 > 2
\n")
-# })
-
-test_that("unparseable blocks aren't double escaped", {
+test_that("preformatted blocks aren't double escaped", {
out <- flatten_para(rd_text("\\preformatted{\\%>\\%}"))
expect_equal(out, "
%>%
\n")
})
@@ -390,11 +382,6 @@ test_that("spaces are preserved in preformatted blocks", {
expect_equal(out, "
^\n\n b\n\n c
\n")
})
-test_that("parseable blocks get R syntax highlighting", {
- out <- flatten_para(rd_text("\\preformatted{foo}"))
- expect_equal(out, "
foo
\n")
-})
-
# Usage -------------------------------------------------------------------
test_that("S4 methods gets comment", {
diff --git a/tests/testthat/test-tweak-reference.R b/tests/testthat/test-tweak-reference.R
new file mode 100644
index 000000000..63cc0390c
--- /dev/null
+++ b/tests/testthat/test-tweak-reference.R
@@ -0,0 +1,85 @@
+test_that("highlights
wrapped in with language info", {
+ html <- xml2::read_html('
+
+ ')
+ tweak_reference_highlighting(html)
+ expect_equal(xpath_attr(html, "//code/span", "class"), c("fl", "op", "fl"))
+ expect_equal(xpath_text(html, "//code/span"), c("1", "+", "2"))
+
+ html <- xml2::read_html('
+
+ ')
+ tweak_reference_highlighting(html)
+ # Select all leaf
to work around variations in pandoc styling
+ expect_equal(xpath_attr(html, "//code//span[not(span)]", "class"), c("fu", "kw", "at"))
+ expect_equal(xpath_text(html, "//code//span[not(span)]"), c("field", ":", " value"))
+})
+
+test_that("highlight unwrapped ", {
+ # If parseable, assume R
+ html <- xml2::read_html('
+
+
1 + 2
+
+ ')
+ tweak_reference_highlighting(html)
+ expect_equal(xpath_attr(html, "//code/span", "class"), c("fl", "op", "fl"))
+ expect_equal(xpath_text(html, "//code/span"), c("1", "+", "2"))
+
+ # If not parseable, leave as is
+ html <- xml2::read_html('
+
+
foo(
+
+ ')
+ tweak_reference_highlighting(html)
+ expect_equal(xpath_length(html, "//code//span"), 0)
+})
+
+
+# highlighting ------------------------------------------------------------
+
+test_that("can highlight R code", {
+ html <- xml2::read_xml('
')
+ tweak_highlight_r(html)
+
+ expect_equal(xpath_attr(html, "//code/span", "class"), c("fl", "op", "fl"))
+ expect_equal(xpath_text(html, "//code/span"), c("1", "+", "2"))
+})
+
+test_that("fails cleanly", {
+ html <- xml2::read_xml('
')
+ expect_equal(tweak_highlight_r(html), FALSE)
+
+ html <- xml2::read_xml('
')
+ expect_equal(tweak_highlight_r(html), FALSE)
+
+ html <- xml2::read_xml('
')
+ expect_equal(tweak_highlight_r(html), FALSE)
+})
+
+test_that("can highlight other languages", {
+ html <- xml2::read_xml('
')
+ tweak_highlight_other(html)
+
+ # Select all leaf
to work around variations in pandoc styling
+ expect_equal(xpath_attr(html, "//code//span[not(span)]", "class"), c("fu", "kw", "at"))
+ expect_equal(xpath_text(html, "//code//span[not(span)]"), c("field", ":", " value"))
+})
+
+test_that("fails cleanly", {
+ html <- xml2::read_xml('')
+ tweak_highlight_other(html)
+ expect_equal(xpath_text(html, "//code"), "")
+
+ html <- xml2::read_xml('')
+ expect_equal(tweak_highlight_other(html), FALSE)
+})