Add odin2-like error codes

DESCRIPTION

@@ -27,6 +27,7 @@ Suggests:
     decor,
     knitr,
     dust,
+    mockery,
     mvtnorm,
     numDeriv,
     pkgload,

NAMESPACE

@@ -1,8 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method("+",mcstate_model)
+S3method(cnd_footer,mcstate2_parse_error)
 export(mcstate_domain_expand)
 export(mcstate_dsl)
+export(mcstate_dsl_error_explain)
 export(mcstate_dsl_parse_distribution)
 export(mcstate_model)
 export(mcstate_model_combine)
@@ -24,4 +26,5 @@ export(mcstate_sampler_nested_random_walk)
 export(mcstate_sampler_random_walk)
 export(with_trace_random)
 importFrom(R6,R6Class)
+importFrom(rlang,cnd_footer)
 useDynLib(mcstate2, .registration = TRUE)

R/dsl-parse-error.R

@@ -0,0 +1,97 @@
+##' Explain error codes produced by mcstate2.  This is a work in progress,
+##' and we would like feedback on what is useful as we improve it.
+##' The idea is that if you see an error you can link through to get
+##' more information on what it means and how to resolve it.  The
+##' current implementation of this will send you to the rendered
+##' vignettes, but in future we will arrange for offline rendering
+##' too.
+##'
+##' @title Explain mcstate2 error
+##'
+##' @param code The error code, as a string, in the form `Exxx` (a
+##'   capital "E" followed by three numbers)
+##'
+##' @return Nothing, this is called for its side effect only
+##'
+##' @export
+mcstate_dsl_error_explain <- function(code) {
+  ## See odin2 for the canonical implementation of this, we're just
+  ## shaddowing it here really as our dsl is much simpler.  Note that
+  ## error codes from mcstate are three numbers long, whereas they are
+  ## four long in odin so that it's easy (for us) to tell who the
+  ## error belongs to.
+  assert_scalar_character(code)
+  if (!grepl("^E[0-9]{3}$", code)) {
+    cli::cli_abort("Invalid code '{code}', should match 'Exxx'",
+                   arg = "code")
+  }
+  txt <- dsl_errors[[code]]
+  if (is.null(txt)) {
+    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")
+  }
+  url <- sprintf(
+    "https://mrc-ide.github.io/mcstate2/articles/dsl-errors.html#%s",
+    tolower(code))
+  utils::browseURL(url)
+}
+
+
+dsl_parse_error <- function(msg, code, src, call, ...,
+                            .envir = parent.frame()) {
+  stopifnot(grepl("^E[0-9]{3}$", code))
+  cli::cli_abort(msg,
+                 class = "mcstate2_parse_error",
+                 code = code,
+                 src = src,
+                 call = call,
+                 ...,
+                 .envir = .envir)
+}
+
+
+##' @importFrom rlang cnd_footer
+##' @export
+cnd_footer.mcstate2_parse_error <- function(cnd, ...) {
+  detail <- c(">" = "In expression",
+              format_error_src(cnd$src))
+  for (i in seq_along(cnd$context)) {
+    detail <- c(detail,
+                "",
+                i = names(cnd$context)[[i]],
+                format_error_src(cnd$context[[i]]))
+  }
+  ## Annoyingly, there's no way of marking text as whitespace
+  ## preserving within cli, so we need to do a substitution here for
+  ## "nonbreaking space" which does ok.  We should also convert tabs
+  ## to some number of spaces, probably.
+  detail <- gsub(" ", "\u00a0", detail)
+
+
+  code <- cnd$code
+  ## See https://cli.r-lib.org/reference/links.html#click-to-run-code
+  ## RStudio will only run code in namespaced form
+  explain <- cli::format_inline(
+    paste("For more information, run",
+          "{.run mcstate2::mcstate2_dsl_error_explain(\"{code}\")}"))
+  c(detail, i = explain)
+}
+
+
+## TODO: this is nicer than what we do in odin.  I wonder if it might
+## make sense to try and have odin2 depend on the code here?
+format_error_src <- function(src) {
+  str <- attr(src, "str", exact = TRUE)
+  if (is.null(str)) {
+    detail <- deparse(src)
+  } else {
+    ## We can adjust the formatting here later, but this will
+    ## hopefully be fairly nice for users.
+    lines <- seq(attr(src, "line"), length.out = length(str))
+    detail <- sprintf("%s| %s", cli::col_grey(format(lines, width = 3)), str)
+  }
+  detail
+}

R/dsl-parse.R

@@ -1,8 +1,8 @@
-dsl_parse <- function(exprs) {
-  exprs <- lapply(exprs, dsl_parse_expr)
+dsl_parse <- function(exprs, call) {
+  exprs <- lapply(exprs, dsl_parse_expr, call)
 
-  dsl_parse_check_duplicates(exprs)
-  dsl_parse_check_usage(exprs)
+  dsl_parse_check_duplicates(exprs, call)
+  dsl_parse_check_usage(exprs, call)
 
   name <- vcapply(exprs, "[[", "name")
   parameters <- name[vcapply(exprs, "[[", "type") == "stochastic"]
@@ -11,32 +11,33 @@ dsl_parse <- function(exprs) {
 }
 
 
-dsl_parse_expr <- function(expr) {
+dsl_parse_expr <- function(expr, call) {
   if (rlang::is_call(expr, "~")) {
-    dsl_parse_expr_stochastic(expr)
+    dsl_parse_expr_stochastic(expr, call)
   } else if (rlang::is_call(expr, c("<-", "="))) {
-    dsl_parse_expr_assignment(expr)
+    dsl_parse_expr_assignment(expr, call)
   } else {
     dsl_parse_error(
       "Unhandled expression; expected something involving '~' or '<-'",
-      expr)
+      "E101", expr, call)
   }
 }
 
 
-dsl_parse_expr_stochastic <- function(expr) {
+dsl_parse_expr_stochastic <- function(expr, call) {
   lhs <- expr[[2]]
   if (!rlang::is_symbol(lhs)) {
     ## TODO: once we support array expressions this will be relaxed a
     ## little to allow lhs to be 'symbol[index]'
-    dsl_parse_error("Expected lhs of '~' relationship to be a symbol", expr)
+    dsl_parse_error("Expected lhs of '~' relationship to be a symbol",
+                    "E102", expr, call)
   }
   rhs <- expr[[3]]
 
   res <- mcstate_dsl_parse_distribution(rhs)
 
   if (!res$success) {
-    dsl_parse_error(res$error, expr)
+    dsl_parse_error(res$error, "E103", expr, call)
   }
 
   ## This probably requires a little more care in order to know that
@@ -55,12 +56,13 @@ dsl_parse_expr_stochastic <- function(expr) {
 }
 
 
-dsl_parse_expr_assignment <- function(expr) {
+dsl_parse_expr_assignment <- function(expr, call) {
   lhs <- expr[[2]]
   if (!rlang::is_symbol(lhs)) {
     ## TODO: once we support array expressions this will be relaxed a
     ## little to allow lhs to be 'symbol[index]'
-    dsl_parse_error("Expected lhs of assignment to be a symbol", expr)
+    dsl_parse_error("Expected lhs of assignment to be a symbol",
+                   "E104", expr, call)
   }
   rhs <- expr[[3]]
   ## I suspect we'll need to be quite restrictive about what
@@ -74,50 +76,7 @@ dsl_parse_expr_assignment <- function(expr) {
 }
 
 
-dsl_parse_error <- function(msg, expr, ..., envir = parent.frame(),
-                            call = NULL) {
-  cli::cli_abort(msg,
-                 ...,
-                 expr = expr,
-                 footer = dsl_parse_error_show_context,
-                 .envir = envir,
-                 class = "mcstate2_parse_error",
-                 call = call)
-}
-
-
-dsl_parse_error_show_context <- function(cnd, ...) {
-  detail <- c(">" = "In expression",
-              format_error_expr(cnd$expr))
-  for (i in seq_along(cnd$context)) {
-    detail <- c(detail,
-                "",
-                i = names(cnd$context)[[i]],
-                format_error_expr(cnd$context[[i]]))
-  }
-  ## Annoyingly, there's no way of marking text as whitespace
-  ## preserving within cli, so we need to do a substitution here for
-  ## "nonbreaking space" which does ok.  We should also convert tabs
-  ## to some number of spaces, probably.
-  gsub(" ", "\u00a0", detail)
-}
-
-
-format_error_expr <- function(expr) {
-  str <- attr(expr, "str", exact = TRUE)
-  if (is.null(str)) {
-    detail <- deparse(expr)
-  } else {
-    ## We can adjust the formatting here later, but this will
-    ## hopefully be fairly nice for users.
-    lines <- seq(attr(expr, "line"), length.out = length(str))
-    detail <- sprintf("%s| %s", cli::col_grey(format(lines, width = 3)), str)
-  }
-  detail
-}
-
-
-dsl_parse_check_duplicates <- function(exprs) {
+dsl_parse_check_duplicates <- function(exprs, call) {
   type <- vcapply(exprs, "[[", "type")
   name <- vcapply(exprs, "[[", "name")
   i_err <- anyDuplicated(name)
@@ -127,23 +86,27 @@ dsl_parse_check_duplicates <- function(exprs) {
     if (type[[i_err]] == type[[i_prev]]) {
       if (type[[i_err]] == "stochastic") {
         msg <- "Duplicated relationship '{name_err}'"
+        code <- "E201"
       } else {
         msg <- "Duplicated assignment '{name_err}'"
+        code <- "E202"
       }
     } else {
       if (type[[i_err]] == "stochastic") {
         msg <- "Relationship '{name_err}' shadows previous assignment"
+        code <- "E203"
       } else {
         msg <- "Assignment '{name_err}' shadows previous relationship"
+        code <- "E204"
       }
     }
     context <- list("Previous definition" = exprs[[i_prev]]$expr)
-    dsl_parse_error(msg, exprs[[i_err]]$expr, context = context)
+    dsl_parse_error(msg, code, exprs[[i_err]]$expr, call, context = context)
   }
 }
 
 
-dsl_parse_check_usage <- function(exprs) {
+dsl_parse_check_usage <- function(exprs, call) {
   name <- vcapply(exprs, "[[", "name")
   for (i in seq_along(exprs)) {
     e <- exprs[[i]]
@@ -165,7 +128,7 @@ dsl_parse_check_usage <- function(exprs) {
       ## probably something rlang can do for us as it does that with
       ## the 'arg' argument to rlang::abort already?
       dsl_parse_error("Invalid use of variable{?s} {squote(err)}",
-                      e$expr, context = context)
+                      "E205", e$expr, call, context = context)
     }
   }
 }

R/dsl-preprocess.R

@@ -6,16 +6,17 @@
 ## able to point at individual errors _within_ the tree (so specific
 ## arguments etc) but that's quite hard so for now we will just hold a
 ## deparsed expression as an attribute of each expression.
-dsl_preprocess <- function(x, type = NULL) {
+dsl_preprocess <- function(x, type = NULL, call = NULL) {
   if (rlang::is_call(x, "quote")) {
     given <- rlang::expr_deparse(x)
     alt <- rlang::expr_deparse(x[[2]])
     cli::cli_abort(
       c("You have an extra layer of quote() around 'x'",
-        i = "You passed '{given}' but probably meant to pass '{alt}'"))
+        i = "You passed '{given}' but probably meant to pass '{alt}'"),
+      call = call)
   }
 
-  type <- preprocess_detect(x, type)
+  type <- preprocess_detect(x, type, call)
   if (type == "expression") {
     if (inherits(x, "{")) {
       exprs <- as.list(x[-1L])
@@ -81,7 +82,7 @@ preprocess_detect <- function(x, type, call = NULL) {
                      call = call)
     }
   } else {
-    cli::cli_abort("Invalid input for 'x'")
+    cli::cli_abort("Invalid input for 'x'", call = call)
   }
   as
 }

R/dsl.R

@@ -38,21 +38,23 @@ mcstate_dsl <- function(x, type = NULL) {
   } else {
     x <- rlang::quo_get_expr(quo)
   }
-  exprs <- dsl_preprocess(x, type)
-  dat <- dsl_parse(exprs)
+  call <- environment()
+  exprs <- dsl_preprocess(x, type, call)
+  dat <- dsl_parse(exprs, call)
   dsl_generate(dat)
 }
 
 
 mcstate_dsl_parse <- function(x, type = NULL) {
+  call <- environment()
   quo <- rlang::enquo(x)
   if (rlang::quo_is_symbol(quo)) {
     x <- rlang::eval_tidy(quo)
   } else {
     x <- rlang::quo_get_expr(quo)
   }
   exprs <- dsl_preprocess(x, type)
-  dsl_parse(exprs)
+  dsl_parse(exprs, call)
 }
 
 

_pkgdown.yml

@@ -13,6 +13,7 @@ reference:
   - title: Domain specific language
     contents:
       - mcstate_dsl
+      - mcstate_dsl_error_explain
       - dsl-distributions
 
   - subtitle: Advanced