Fix asserttion mixup

We had two assert_that() implementations, one for the
embedded async, which needs an `on_failure()<-` function.

.gitignore

@@ -8,3 +8,4 @@ rhub.Rproj
 /man/_cache
 /README_cache
 /README.html
+/dev-lib

DESCRIPTION

@@ -43,3 +43,4 @@ Suggests:
     testthat (>= 3.0.0),
     webfakes
 Encoding: UTF-8
+Config/testthat/edition: 3

R/aa-assertthat.R

@@ -1,64 +1,100 @@
-
-assert_that <- function(..., env = parent.frame(), msg = NULL) {
-  res <- see_if(..., env = env, msg = msg)
-  if (res) return(TRUE)
-
-  throw(new_assert_error(attr(res, "msg")))
-}
-
-new_assert_error <- function (message, call = NULL) {
-  cond <- new_error(message, call. = call)
-  class(cond) <- c("assert_error", class(cond))
-  cond
+# nocov start
+# This is for the embedded async
+
+`on_failure<-` <- function (x, value) {
+  stopifnot(
+    is.function(x),
+    identical(names(formals(value)), c("call", "env"))
+  )
+  attr(x, "msg") <- value
+  x
 }
 
-see_if <- function(..., env = parent.frame(), msg = NULL) {
+assert_that <- function(..., env = parent.frame(), msg = NULL) {
   asserts <- eval(substitute(alist(...)))
 
   for (assertion in asserts) {
     res <- tryCatch({
       eval(assertion, env)
-    }, error = function(e) {
+    }, assertError = function(e) {
       structure(FALSE, msg = e$message)
     })
     check_result(res)
+    if (res) next
 
-    # Failed, so figure out message to produce
-    if (!res) {
-      if (is.null(msg))
-        msg <- get_message(res, assertion, env)
-      return(structure(FALSE, msg = msg))
+    if (is.null(msg)) {
+      msg <- get_message(res, assertion, env)
+      evalenv <- attr(res, "env") %||% env
+    } else {
+      evalenv <- env
     }
+    throw(assert_error(
+      assertion,
+      res,
+      msg,
+      call. = sys.call(-1),
+      .envir = evalenv,
+    ), frame = env)
   }
 
-  res
+  invisible(TRUE)
+}
+
+assert_error <- function(assertion, result, msg, .data = NULL, .class = NULL,
+                         .envir = parent.frame(), call. = TRUE) {
+
+  myenv <- new.env(parent = .envir)
+  myenv$.arg <- if (length(assertion) >= 2) deparse(assertion[[2]])
+  myenv$.arg2 <- if (length(assertion) >= 3) deparse(assertion[[3]])
+  .hide_from_trace <- TRUE
+  cnd <- new_error(
+    call. = call.,
+    cli::format_error(
+      .envir = myenv,
+      msg
+    )
+  )
+
+  if (length(.data)) cnd[names(.data)] <- .data
+  if (length(class)) class(cnd) <- unique(c(.class, "assertError", class(cnd)))
+
+  cnd
 }
 
 check_result <- function(x) {
-  if (!is.logical(x))
-    throw(new_assert_error("assert_that: assertion must return a logical value"))
-  if (any(is.na(x)))
-    throw(new_assert_error("assert_that: missing values present in assertion"))
+  if (!is.logical(x)) {
+    throw(pkg_error(
+      "{.fun assert_that}: assertion must return a logical value.",
+      "i" = "it returned {.type {x}} instead."
+    ))
+  }
+
   if (length(x) != 1) {
-    throw(new_assert_error("assert_that: length of assertion is not 1"))
+    throw(pkg_error(
+      "{.fun assert_that}: assertion must return a scalar.",
+      "i" = "it returned a vector of length {length(x)}."
+    ))
+  }
+
+  if (any(is.na(x))) {
+    throw(pkg_error(
+      "{.fun assert_that}: assertion must not return {.code NA}."
+    ))
   }
 
   TRUE
 }
 
 get_message <- function(res, call, env = parent.frame()) {
-  stopifnot(is.call(call), length(call) >= 1)
-
   if (has_attr(res, "msg")) {
     return(attr(res, "msg"))
   }
 
   f <- eval(call[[1]], env)
-  if (!is.primitive(f)) call <- match.call(f, call)
+  if (is.call(call) && !is.primitive(f)) call <- match.call(f, call)
   fname <- deparse(call[[1]])
 
-  fail <- on_failure(f) %||% base_fs[[fname]] %||% fail_default
-  fail(call, env)
+  base_fs[[fname]] %||% fail_default(call, env)
 }
 
 # The default failure message works in the same way as stopifnot, so you can
@@ -71,21 +107,91 @@ fail_default <- function(call, env) {
       call_string <- paste0(call_string[1L], "...")
   }
 
-  paste0(call_string, " is not TRUE")
+  paste0(call_string, " is not true")
 }
 
-on_failure <- function(x) attr(x, "fail")
+has_attr <- function(x, which) {
+  if (!is.null(attr(x, which, exact = TRUE))) return(TRUE)
+  structure(
+    FALSE,
+    msg = "{.arg {(.arg)}} must have attribute {.code {which}}.",
+    env = environment()
+  )
+}
+"%has_attr%" <- has_attr
 
-"on_failure<-" <- function(x, value) {
-  stopifnot(is.function(x), identical(names(formals(value)), c("call", "env")))
-  attr(x, "fail") <- value
-  x
+base_fs <- new.env(parent = emptyenv())
+
+# nocov start
+
+logical_is_not <- function(failed) {
+  paste0("{.arg {(.arg)}} must ", failed, " {.arg {(.arg2)}}.")
 }
 
-has_attr <- function(x, which) !is.null(attr(x, which, exact = TRUE))
-on_failure(has_attr) <- function(call, env) {
-  paste0(deparse(call$x), " does not have attribute ", eval(call$which, env))
+base_fs$"==" <- logical_is_not("equal")
+base_fs$"<" <-  logical_is_not("be less than")
+base_fs$">" <-  logical_is_not("be greater than")
+base_fs$">=" <- logical_is_not("be greater than or equal to")
+base_fs$"<=" <- logical_is_not("be less than or equal to")
+base_fs$"!=" <- logical_is_not("not be equal to")
+
+is_not <- function(thing) {
+  paste0("{.arg {(.arg)}} must be ", thing, ".")
 }
-"%has_attr%" <- has_attr
 
-base_fs <- new.env(parent = emptyenv())
+# nocov end
+
+# Vectors
+base_fs$is.atomic <- is_not("an atomic vector")
+base_fs$is.character <- is_not("a character vector")
+base_fs$is.complex <- is_not("a complex vector")
+base_fs$is.double <- is_not("a numeric vector")
+base_fs$is.integer <- is_not("an integer vector")
+base_fs$is.numeric <- is_not("a numeric or integer vector")
+base_fs$is.raw <- is_not("a raw vector")
+base_fs$is.vector <- is_not("an atomic vector without attributes")
+
+# Factors
+base_fs$is.factor <- is_not("a factor")
+base_fs$is.ordered <- is_not("an ordered factor")
+
+# More complicated data structures
+base_fs$is.array <- is_not("an array")
+base_fs$is.data.frame <- is_not("a data frame")
+base_fs$is.list <- is_not("a list")
+base_fs$is.matrix <- is_not("a matrix")
+base_fs$is.null <- is_not("{.code NULL}")
+
+# Functions and environments
+base_fs$is.environment <- is_not("an environment")
+base_fs$is.function <- is_not("a function")
+base_fs$is.primitive <- is_not("a primitive function")
+
+# Computing on the language
+base_fs$is.call <- is_not("a quoted call")
+base_fs$is.expression <- is_not("an expression object")
+base_fs$is.name <- is_not("a name")
+base_fs$is.pairlist <- is_not("a pairlist")
+base_fs$is.recursive <- is_not("a recursive object")
+base_fs$is.symbol <- is_not("a name")
+
+# Catch all
+base_fs$"&&" <-
+  "{.arg {(.arg)}} and {.arg {(.arg2)}} must both be true."
+
+base_fs$"||" <-
+  "One of {.arg {(.arg)}} and {.arg {(.arg2)}} must be true."
+
+base_fs$any <-
+  "At least one of {.arg {(.arg)}} must be true."
+
+base_fs$all <-
+  "All of {.arg {(.arg)}} must be true."
+
+base_fs$file.exists <-
+  "Path {.arg {(.arg)}} must exist."
+
+base_fs$identical <-
+  "{.arg {(.arg)}} must be identical to {.arg {(.arg2)}}."
+
+# nocov end

R/aaa-async.R

@@ -1,3 +1,4 @@
+# nocov start
 
 #' Create an async function
 #'
@@ -4798,3 +4799,5 @@ external_process <- function(process_generator, error_on_status = TRUE,
     }
   )
 }
+
+# nocov end

R/assertions.R

@@ -4,7 +4,7 @@ is_character <- function(x) {
     structure(
       FALSE,
       msg = "{.arg {(.arg)}} must be a character vector without {.code NA},
-             but it is {.type {x}}",
+             but it is {.type {x}}.",
       env = environment()
     )
   } else if (anyNA(x)) {
@@ -19,6 +19,25 @@ is_character <- function(x) {
   }
 }
 
+is_optional_character <- function(x) {
+  if (is.null(x) || is_character(x)) return(TRUE)
+  if (!is.character(x)) {
+    structure(
+      FALSE,
+      msg = "{.arg {(.arg)}} must be a character vector without {.code NA},
+             or NULL, but it is {.type {x}}.",
+      env = environment()
+    )
+  } else if (anyNA(x)) {
+    structure(
+      FALSE,
+      msg = "{.arg {(.arg)}} must not have {.code NA} values,
+             but it has {sum(is.na(x))} {.code NA} value{?s}.",
+      env = environment()
+    )
+  }
+}
+
 is_string <- function(x) {
   if (is.character(x) && length(x) == 1 && !is.na(x)) return(TRUE)
   if (is.character(x) && length(x) == 1 && is.na(x)) {
@@ -41,7 +60,7 @@ is_optional_string <- function(x) {
   if (is.null(x) || is_string(x)) return(TRUE)
   structure(
     FALSE,
-    msg = "{.arg {(.arg)}} must be a path (character scalar),
+    msg = "{.arg {(.arg)}} must be a string (character scalar) or NULL,
            but it is {.type {x}}.",
     env = environment()
   )
@@ -53,14 +72,16 @@ is_optional_gh_url <- function(x) {
   if (!is_string(x)) {
     structure(
       FALSE,
-      msg = "{.arg gh_url} must be a character string.
-             You supplied {.type {x}}."
+      msg = "{.arg {(.arg)}} must be a character string.
+             You supplied {.type {x}}.",
+      env = environment()
     )
   } else if (!grepl("^https?://", x)) {
     structure(
       FALSE,
-      msg = "{.arg gh_url} must be an HTTP or HTTPS URL.
-             You supplied: {.val {x}}."
+      msg = "{.arg {(.arg)}} must be an HTTP or HTTPS URL.
+             You supplied: {.val {x}}.",
+      env = environment()
     )
   } else {
     TRUE