updating use_testex helper

NAMESPACE

@@ -1,12 +1,12 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(roxygen2::roxy_tag_parse,roxy_tag_expect)
-export(expect_no_error)
+export(fallback_expect_no_error)
 export(s3_register)
 export(test_examples_as_testthat)
 export(testex)
 export(testthat_block)
-export(use_rd_roclet)
+export(use_testex)
 export(use_testex_as_testthat)
 export(with_attached)
 export(with_srcref)

R/testthat.R

@@ -118,7 +118,7 @@ with_srcref <- function(src, expr, envir = parent.frame()) {
 #' @return The value produced by the expectation code
 #'
 #' @export
-expect_no_error <- function(object, ...) {
+fallback_expect_no_error <- function(object, ...) {
   object <- substitute(object)
   act <- list(
     val = tryCatch(eval(object, envir = parent.frame()), error = identity),
@@ -264,9 +264,15 @@ test_files <- function(files, context, ...) {
 wrap_expect_no_error <- function(expr, value) {
   srckey <- srcref_key(expr, path = "root")
   # nocov start
+  expect_no_error <- if (packageVersion("testthat") >= "3.1.5") {
+    quote(testthat::expect_no_error)
+  } else {
+    quote(testex::fallback_expect_no_error)
+  }
+
   bquote(testthat::test_that("example executes without error", {
     testex::with_srcref(.(srckey), {
-      .(value) <<- testex::expect_no_error(.(expr))
+      .(value) <<- .(expect_no_error)(.(expr))
     })
   }))
   # nocov end

R/use.R

@@ -1,9 +1,10 @@
-#' Replace default rd roclet with testex rd roclet
+#' Add `testex` tags and configure package to fully use `testex` features
 #'
 #' @note
-#' The testex roclet aims to be functionally identical to the default roxygen rd
-#' roclet for any default roxygen tags. It replaces the default to intersperse
-#' tests in the midst of existing \code{\\examples{...}} sections of Rd files.
+#' The testex roxygen tags behave similarly to 'roxygen2' `@examples` tags,
+#' with the minor addition of some wrapping code to manage the tests. This
+#' means that they will be integrated into your `@examples` and can be
+#' intermixed between `@examples` tags
 #'
 #' @param path A package source code working directory
 #' @param check A \code{logical} value indicating whether tests should be
@@ -13,19 +14,17 @@
 #'   `DESCRIPTION` file.
 #'
 #' @export
-use_testex <- function(path = getwd(), check = NA, quiet = FALSE) {
-  msg <- if (quiet) identity else message
-  na <- NA_character_
+use_testex <- function(path = getwd(), check = TRUE, quiet = FALSE) {
   path <- file.path(find_package_root(path), "DESCRIPTION")
   desc <- read.dcf(path)
   desc <- read.dcf(path, keep.white = colnames(desc))
 
   report <- report(quiet)
   desc <- update_desc_roxygen(desc, report)
   desc <- update_desc_suggests(desc, report)
-  desc <- update_desc_config_options(desc, check, report)
+  desc <- update_desc_config_options(desc, list(check = check), report)
   update_testthat(path, report)
-  report$show("Configuring `testex`:")
+  report$show("Configuring {.pkg testex}:")
 
   write.dcf(
     desc,
@@ -36,23 +35,40 @@ use_testex <- function(path = getwd(), check = NA, quiet = FALSE) {
   )
 }
 
+
+
+#' A Simple Stateful Reporter Class
+#'
+#' @param quiet Whether output should be shown
+#' @return A class-like environment with a few reporting methods
+#'
+#' @noRd
 report <- function(quiet) {
-  messages <- character()
-  add <- function(message) {
-    messages <<- append(messages, message)
+  messages <- character(0L)
+  add <- function(..., .envir = parent.frame()) {
+    messages <<- append(messages, cliless(..., .envir = .envir))
   }
   show <- function(title) {
-    out <- paste0(title, "\n", paste0(paste0(" * ", messages), collapse = "\n"))
-    if (!quiet && length(messages)) {
-      message(out)
-    } else if (!length(messages)) {
-      message(paste0("No changes made"))
+    if (quiet) return()
+    title <- cliless(title)
+    if (length(messages) > 0) {
+      cat(title, "\n", paste0(" * ", messages, collapse = "\n"), "\n", sep = "")
+    } else {
+      cat(title, "You're already set up!\n")
     }
   }
   environment()
 }
 
 
+
+#' Update Roxygen field in DESCRIPTION
+#'
+#' @param desc A parsed DESCRIPTION matrix
+#' @param report A reporter to aggregate output
+#' @return Used for side-effects of updating DESCRIPTION and reporter
+#'
+#' @noRd
 update_desc_roxygen <- function(desc, report) {
   # update Roxygen settings
   roxygen_orig <- if (!"Roxygen" %in% colnames(desc)) {
@@ -68,17 +84,23 @@ update_desc_roxygen <- function(desc, report) {
   roxygen <- roxygen_orig
   roxygen$packages <- unique(c(roxygen$packages, packageName()))
   if (!identical(roxygen, roxygen_orig)) {
-    msg <- sprintf(
-      'Including `packages = "%s"` in Roxygen DESCRIPTION field',
-      packageName()
+    report$add(
+      "Including {.code package = \"{packageName()}\"} in ",
+      "{.code Roxygen} {.file DESCRIPTION} field"
     )
-    report$add(msg)
   }
 
   roxygen_str <- paste0("\n    ", deparse(roxygen), collapse = "")
   desc_update(desc, Roxygen = roxygen_str)
 }
 
+#' Update Suggests field to DESCRIPTION
+#'
+#' @param desc A parsed DESCRIPTION matrix
+#' @param report A reporter to aggregate output
+#' @return Used for side-effects of updating DESCRIPTION and reporter
+#'
+#' @noRd
 update_desc_suggests <- function(desc, report) {
   # add testex to Suggests
   suggests <- if (!"Suggests" %in% colnames(desc)) {
@@ -93,42 +115,71 @@ update_desc_suggests <- function(desc, report) {
     ws <- min(nchar(gsub("[^ ].*", "", lines)))
     package <- paste0(strrep(" ", ws), packageName())
     suggests <- paste(c(suggests, package), collapse = ",\n")
-    report$add(sprintf('Adding Suggests package "%s"', packageName()))
+    report$add("Adding {.code Suggests} package {.pkg {packageName()}}")
   }
 
   desc_update(desc, Suggests = suggests)
 }
 
-update_desc_config_options <- function(desc, check, report) {
+#' Add Config/pkg/options field to DESCRIPTION
+#'
+#' @param desc A parsed DESCRIPTION matrix
+#' @param options Options to use
+#' @param report A reporter to aggregate output
+#' @return Used for side-effects of updating DESCRIPTION and reporter
+#'
+#' @noRd
+update_desc_config_options <- function(desc, options, report) {
   config <- paste("Config", packageName(), "options", sep = "/")
+  options_orig <- if (!config %in% colnames(desc)) {
+    list()
+  } else {
+    eval(
+      parse(text = desc[1L, config], keep.source = FALSE),
+      envir = new.env(parent = baseenv())
+    )
+  }
 
-  if (!config %in% colnames(desc)) {
+  options_new <- options_orig
+  options_new[names(options)] <- options[names(options)]
+  if (!identical(options_new, options_orig)) {
     desc <- cbind(desc, matrix(NA_character_, dimnames = list(c(), config)))
-    desc[1L, config] <- paste0("\n    ", deparse(list(check = TRUE)))
-    msg <- sprintf(
-      "Configuring DESCRIPTION %s to run testex on R CMD check by default",
-      config
+    desc[1L, config] <- paste0("\n    ", deparse(options_new))
+    report$add(
+      "Configuring {.file DESCRIPTION} {.file {config}} with ",
+      "{.code {deparse(options_new)}}"
     )
-    report$add(msg)
-  } else if (is.logical(check) && !is.na(check)) {
-    desc[1L, config] <- paste0("\n    ", deparse(list(check = check)))
-    msg <- sprintf("Configuring DESCRIPTION %s", config)
-    report$add(smg)
   }
 
   desc
 }
 
+#' Add testthat test for running example tests
+#'
+#' @param path A directory path to use as basis for finding testing suite
+#' @param report A reporter to aggregate output
+#' @return Used for side-effects of adding files and updating reporter
+#'
+#' @noRd
 update_testthat <- function(path, report) {
   tryCatch(
     {
       f <- use_testex_as_testthat(path = path, quiet = TRUE)
-      report$add(sprintf("Adding test file '%s'", f))
+      if (!is.null(f)) report$add("Adding test file {.file {f}}")
     },
     error = function(e) NULL
   )
 }
 
+
+
+#' Update Fields in the DESCRIPTION file
+#'
+#' @param desc A Parsed `DESCRPITION` file matrix
+#' @param ... Named fields to update
+#' @return A `DESCRIPTION` matrix
+#'
+#' @noRd
 desc_update <- function(desc, ...) {
   cols <- list(...)
   new_cols <- setdiff(names(cols), colnames(desc))
@@ -151,6 +202,57 @@ desc_update <- function(desc, ...) {
 
 
 
+#' {cli}less
+#'
+#' Pretty format text without cli? As if! Call cli if available, or use a
+#' heavily simplified version of glue, used as fallback.
+#'
+#' @param ... Used to form input string.
+#' @param .envir Environment in which to evaluate expressions.
+#' @return A formatted string.
+#'
+#' @noRd
+cliless <- function(..., .envir = parent.frame(), .less = FALSE) {
+  if (!.less && !is.null(tryCatch(ns <- getNamespace("cli"), error = function(e) NULL))) {
+    return(ns$format_inline(..., .envir = .envir))
+  }
+
+  re <- "{(?:\\.([^{} ]+) )?([^{}]+|[^{]*(?R)[^}]*)}"
+  str <- paste0(..., collapse = "")
+  m <- gregexec(re, str, perl = TRUE)[[1]]
+  if (!is.matrix(m)) return(str)
+  l <- attr(m, "match.length")
+
+  if (ncol(m) == 1 && m[1, 1] == 1 && l[1, 1] == nchar(str)) {
+    # when entire string is a glue-ish cli expression
+    style <- substring(str, s <- m[2, 1], s + l[2, 1] - 1L)
+    expr <- substring(str, s <- m[3, 1], s + l[3, 1] - 1L)
+    return(switch(style,
+      "code" = paste0("`", cliless(expr, .envir = .envir, .less = .less), "`"),
+      "file" = paste0("'", cliless(expr, .envir = .envir, .less = .less), "'"),
+      "pkg" = paste0("{", cliless(expr, .envir = .envir, .less = .less), "}"),
+      {
+        text <- cliless(expr, .envir = .envir, .less = .less)
+        format(eval(parse(text = text), envir = .envir))
+      }
+    ))
+  }
+
+  for (col in rev(seq_len(ncol(m)))) {
+    start <- m[1, col]
+    end <- start + l[1, col] - 1L
+    str <- paste0(
+      substring(str, 1L, start - 1L),
+      cliless(substring(str, start, end), .envir = .envir, .less = .less),
+      substring(str, end + 1L)
+    )
+  }
+
+  str
+}
+
+
+
 #' Run examples as testthat expectations
 #'
 #' @param path A package source code working directory
@@ -163,25 +265,29 @@ desc_update <- function(desc, ...) {
 #'
 #' @importFrom utils packageName
 #' @export
-use_testex_as_testthat <- function(path = getwd(), context = "testex", quiet = FALSE) {
+use_testex_as_testthat <- function(
+    path = getwd(), context = "testex", quiet = FALSE) {
   path <- find_package_root(path)
-  package <- read.dcf(file.path(path, "DESCRIPTION"), fields = "Package")[[1L]]
   testthat_path <- file.path(path, "tests", "testthat")
   test_file <- file.path(testthat_path, paste0("test-", context, ".R"))
 
   if (!dir.exists(testthat_path)) {
-    if (!quiet) stop(
-      "It looks like you don't have any testthat tests yet. Start ",
-      "by setting up your package to use testthat, then try again."
-    )
+    if (!quiet) {
+      stop(
+        "It looks like you don't have any testthat tests yet. Start ",
+        "by setting up your package to use testthat, then try again."
+      )
+    }
     return()
   }
 
   if (file.exists(test_file)) {
-    if (!quiet) stop(sprintf(
-      "testthat test file '%s' already exists.",
-      basename(test_file)
-    ))
+    if (!quiet) {
+      stop(sprintf(
+        "testthat test file '%s' already exists.",
+        basename(test_file)
+      ))
+    }
     return()
   }