Merge pull request #4 from reside-ic/mrc-5766

Add support for odin2-style error explanation

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: reside.utils
 Title: Common Utilities
-Version: 0.1.0
+Version: 0.2.0
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Imperial College of Science, Technology and Medicine",
@@ -11,14 +11,17 @@ Description: Some common utilities that we commonly use in other
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.1
+RoxygenNote: 7.3.1
 URL: https://reside-ic.github.io/reside.utils, https://github.com/reside-ic/reside.utils
 BugReports: https://github.com/reside-ic/reside.utils/issues
 Imports:
     cli,
-    fs
+    commonmark,
+    fs,
+    xml2
 Suggests:
     mockery,
+    pkgdown,
     pkgload,
     rmarkdown,
     usethis,

NAMESPACE

@@ -1 +1,3 @@
 # Generated by roxygen2: do not edit by hand
+
+export(errors_parse)

R/errors-parse.R

@@ -0,0 +1,153 @@
+##' Parse errors from vignette
+##'
+##' @title Parse errors from vignette
+##'
+##' @param path_rmd Path to the .Rmd file containing the error
+##'   descriptions
+##'
+##' @param pattern A regular expression matching each error message,
+##'   e.g., `E[0-9]{4}`.  This should not include beginning or end of
+##'   string markers.
+##'
+##' @param cmd_explain The name of the command to explain an error
+##'
+##' @param check Logical, indicating if we should check that we can
+##'   render everything we produce
+##'
+##' @return A list, save this within the package
+##'
+##' @export
+errors_parse <- function(path_rmd, pattern, cmd_explain, check = TRUE) {
+  assert_scalar_character(cmd_explain)
+  dat <- errors_read(path_rmd, pattern)
+  info <- list(cmd_explain = cmd_explain)
+  errors <- Map(error_parse, names(dat), dat, MoreArgs = list(info = info))
+  if (check) {
+    cli::cli_alert_info("Checking errors render")
+    for (err in errors) {
+      utils::capture.output(suppressMessages(error_render(err, TRUE)))
+    }
+    cli::cli_alert_success("...all ok")
+  }
+  list(
+    url = errors_url(path_rmd),
+    pattern = list(
+      local = pattern,
+      complete = sprintf("^%s$", pattern),
+      hint = pattern_to_hint(pattern)),
+    errors = errors)
+}
+
+
+errors_url <- function(path_rmd) {
+  pkg <- pkgdown::as_pkgdown(dirname(dirname(path_rmd)))
+  i <- match(basename(path_rmd), basename(pkg$vignettes$file_in))
+  file.path(pkg$meta$url, pkg$vignettes$file_out[[i]])
+}
+
+
+pattern_to_hint <- function(pattern) {
+  re <- "^(.+)\\[0-9\\]\\{([0-9])\\}$"
+  if (grepl(re, pattern)) {
+    paste0(sub(re, "\\1", pattern),
+           strrep("x", as.integer(sub(re, "\\2", pattern))))
+  } else {
+    pattern
+  }
+}
+
+
+errors_read <- function(path_rmd, pattern) {
+  txt <- readLines(path_rmd)
+  re <- sprintf("^# `(%s)`$", pattern)
+  i <- grep(re, txt)
+
+  if (length(setdiff(grep("^# ", txt), i)) > 0) {
+    cli::cli_abort(
+      "Some headings in '{path_rmd}' don't match expected pattern")
+  }
+
+  ret <- Map(function(from, to) trim_blank(txt[from:to]),
+             i + 1, c(i[-1] - 1, length(txt)))
+  names(ret) <- sub(re, "\\1", txt[i])
+  ret
+}
+
+
+error_parse <- function(name, txt, info) {
+  list(code = name,
+       plain = txt,
+       parsed = error_parse_md(txt, info))
+}
+
+
+error_parse_md <- function(txt, info) {
+  xml <- xml2::read_xml(commonmark::markdown_xml(txt))
+  lapply(xml2::xml_children(xml), error_parse_node, info)
+}
+
+
+error_parse_node <- function(x, info) {
+  nm <- xml2::xml_name(x)
+  switch(nm,
+         paragraph = error_parse_paragraph(x, info),
+         code_block = error_parse_code_block(x, info),
+         list = error_parse_list(x, info),
+         ## Hard, inline:
+         link = error_parse_link(x, info),
+         ## Easy, inline:
+         code = sprintf("{.code %s}", xml2::xml_text(x)),
+         emph = sprintf("{.emph %s}", xml2::xml_text(x)),
+         strong = sprintf("{.strong %s}", xml2::xml_text(x)),
+         text = xml2::xml_text(x),
+         cli::cli_abort("Unknown node in md: '{nm}'"))
+}
+
+
+error_parse_list <- function(x, info) {
+  items <- xml2::xml_children(x)
+  stopifnot(all(vapply(items, xml2::xml_name, "") == "item"))
+  items <- lapply(items, function(x) error_parse_node(xml2::xml_child(x), info))
+  list(type = "list",
+       mode = xml2::xml_attr(x, "type"),
+       items = items)
+}
+
+
+error_parse_paragraph <- function(x, info) {
+  txt <- vapply(xml2::xml_children(x), error_parse_node, "", info)
+  list(type = "paragraph",
+       text = paste(txt, collapse = ""))
+}
+
+
+error_parse_code_block <- function(x, info) {
+  list(type = "code_block",
+       text = strsplit(sub("\n$", "", xml2::xml_text(x)), "\n")[[1]])
+}
+
+
+error_parse_link <- function(x, info) {
+  target <- xml2::xml_attr(x, "destination")
+  if (grepl("^#(.+)$", target)) {
+    code <- xml2::xml_text(x)
+    sprintf('{.run %s("%s")}', info$cmd_explain, code)
+  } else {
+    txt <- paste(vapply(xml2::xml_children(x), error_parse_node, "", info),
+                 collapse = "")
+    sprintf("{.href [%s](%s)}", target, txt)
+  }
+}
+
+
+trim_blank <- function(x) {
+  i <- 1L
+  j <- length(x)
+  while (x[[i]] == "" && i < j) {
+    i <- i + 1L
+  }
+  while (x[[j]] == "" && j > i) {
+    j <- j - 1L
+  }
+  x[i:j]
+}

R/standalone-error-render.R

@@ -0,0 +1,70 @@
+# ---
+# repo: reside/reside.utils
+# file: standalone-errors-render.R
+# dependencies: standalone-utils-assert.R
+# imports: cli
+# ---
+error_explain <- function(errors, code, how, call = parent.frame()) {
+  assert_scalar_character(code, name = "code", call = call)
+  how <- match_value(how, c("pretty", "plain", "link"),
+                     name = "how", call = call)
+
+  if (!grepl(errors$pattern$complete, code)) {
+    cli::cli_abort(
+      "Invalid code '{code}', should match '{errors$pattern$hint}'",
+      arg = "code", call = call)
+  }
+  err <- errors$errors[[code]]
+  if (is.null(err)) {
+    cli::cli_abort(
+      c("Error '{code}' is undocumented",
+        i = paste("If you were directed here from an error message, please",
+                  "let us know (e.g., file an issue or send us a message)")),
+      arg = "code", call = call)
+  }
+  if (how == "link") {
+    url <- sprintf("%s#%s",errors$url, tolower(code))
+    utils::browseURL(url)
+  } else {
+    error_render(err, how == "pretty")
+  }
+}
+
+
+error_render <- function(err, pretty) {
+  render_paragraph <- function(el) {
+    cli::cli_par()
+    cli::cli_text(el$text)
+  }
+
+  render_code_block <- function(el) {
+    cli::cli_par()
+    cli::cli_code(paste0("    ", el$text))
+  }
+
+  render_list <- function(el) {
+    cli::cli_par()
+    if (el$mode == "bullet") {
+      cli::cli_ul()
+    } else {
+      cli::cli_ol()
+    }
+    for (i in el$items) {
+      cli::cli_li(i$text)
+    }
+  }
+
+  if (pretty) {
+    cli::cli_h1(err$code)
+    for (el in err$parsed) {
+      switch(
+        el$type,
+        paragraph = render_paragraph(el),
+        code_block = render_code_block(el),
+        list = render_list(el),
+        cli::cli_abort("Unknown error block type '{el$type}' while rendering"))
+    }
+  } else {
+    writeLines(c(sprintf("# %s", err$code), "", err$plain))
+  }
+}