1#' The building block of all `expect_` functions
2#'
3#' Call `expect()` when writing your own expectations. See
4#' `vignette("custom-expectation")` for details.
5#'
6#' @param ok `TRUE` or `FALSE` indicating if the expectation was successful.
7#' @param failure_message Message to show if the expectation failed.
8#' @param info Character vector continuing additional information. Included
9#'   for backward compatibility only and new expectations should not use it.
10#' @param srcref Location of the failure. Should only needed to be explicitly
11#'   supplied when you need to forward a srcref captured elsewhere.
12#' @param trace An optional backtrace created by [rlang::trace_back()].
13#'   When supplied, the expectation is displayed with the backtrace.
14#' @param trace_env If `is.null(trace)`, this is used to automatically
15#'   generate a traceback running from `test_code()`/`test_file()` to
16#'   `trace_env`. You'll generally only need to set this if you're wrapping
17#'   an expectation inside another function.
18#' @return An expectation object. Signals the expectation condition
19#'   with a `continue_test` restart.
20#'
21#' @details
22#'
23#' While `expect()` creates and signals an expectation in one go,
24#' `exp_signal()` separately signals an expectation that you
25#' have manually created with [new_expectation()]. Expectations are
26#' signalled with the following protocol:
27#'
28#' * If the expectation is a failure or an error, it is signalled with
29#'   [base::stop()]. Otherwise, it is signalled with
30#'   [base::signalCondition()].
31#'
32#' * The `continue_test` restart is registered. When invoked, failing
33#'   expectations are ignored and normal control flow is resumed to
34#'   run the other tests.
35#'
36#' @seealso [exp_signal()]
37#' @export
38expect <- function(ok, failure_message,
39                   info = NULL,
40                   srcref = NULL,
41                   trace = NULL,
42                   trace_env = caller_env()) {
43  type <- if (ok) "success" else "failure"
44
45  # Preserve existing API which appear to be used in package test code
46  # Can remove in next major release
47  if (missing(failure_message)) {
48    warn("`failure_message` is missing, with no default.")
49    message <- "unknown failure"
50  } else {
51    # A few packages include code in info that errors on evaluation
52    if (ok) {
53      message <- paste(failure_message, collapse = "\n")
54    } else {
55      message <- paste(c(failure_message, info), collapse = "\n")
56    }
57  }
58
59  if (!ok) {
60    if (is.null(trace)) {
61      trace <- trace_back(
62        top = getOption("testthat_topenv"),
63        bottom = trace_env
64      )
65    }
66
67    # Only show if there's at least one function apart from the expectation
68    if (trace_length(trace) <= 1) {
69      trace <- NULL
70    }
71  }
72
73  exp <- expectation(type, message, srcref = srcref, trace = trace)
74  exp_signal(exp)
75}
76
77
78#' Construct an expectation object
79#'
80#' For advanced use only. If you are creating your own expectation, you should
81#' call [expect()] instead. See `vignette("custom-expectation")` for more
82#' details.
83#'
84#' Create an expectation with `expectation()` or `new_expectation()`
85#' and signal it with `exp_signal()`.
86#'
87#' @param type Expectation type. Must be one of "success", "failure", "error",
88#'   "skip", "warning".
89#' @param message Message describing test failure
90#' @param srcref Optional `srcref` giving location of test.
91#' @inheritParams expect
92#' @keywords internal
93#' @export
94expectation <- function(type, message, srcref = NULL, trace = NULL) {
95  new_expectation(type, message, srcref = srcref, trace = trace)
96}
97#' @rdname expectation
98#' @param ... Additional attributes for the expectation object.
99#' @param .subclass An optional subclass for the expectation object.
100#' @export
101new_expectation <- function(type,
102                            message,
103                            ...,
104                            srcref = NULL,
105                            trace = NULL,
106                            .subclass = NULL) {
107  type <- match.arg(type, c("success", "failure", "error", "skip", "warning"))
108
109  structure(
110    list(
111      message = message,
112      srcref = srcref,
113      trace = trace
114    ),
115    class = c(
116      .subclass,
117      paste0("expectation_", type),
118      "expectation",
119      # Make broken expectations catchable by try()
120      if (type %in% c("failure", "error")) "error",
121      "condition"
122    ),
123    ...
124  )
125}
126#' @rdname expectation
127#' @param exp An expectation object, as created by
128#'   [new_expectation()].
129#' @export
130exp_signal <- function(exp) {
131  withRestarts(
132    if (expectation_broken(exp)) {
133      stop(exp)
134    } else {
135      signalCondition(exp)
136    },
137    continue_test = function(e) NULL
138  )
139
140  invisible(exp)
141}
142
143
144#' @export
145#' @rdname expectation
146#' @param x object to test for class membership
147is.expectation <- function(x) inherits(x, "expectation")
148
149#' @export
150print.expectation <- function(x, ...) {
151  cat(cli::style_bold("<", paste0(class(x), collapse = "/"), ">"), "\n", sep = "")
152  cat(format(x), "\n", sep = "")
153  invisible(x)
154}
155
156#' @export
157format.expectation_success <- function(x, ...) {
158  "As expected"
159}
160
161#' @export
162format.expectation <- function(x, simplify = "branch", ...) {
163  # Access error fields with `[[` rather than `$` because the
164  # `$.Throwable` from the rJava package throws with unknown fields
165  if (is.null(x[["trace"]]) || trace_length(x[["trace"]]) == 0L) {
166    return(x$message)
167  }
168
169  max_frames <- if (simplify == "branch") 20 else NULL
170
171  trace_lines <- format(
172    x$trace,
173    simplify = simplify,
174    ...,
175    max_frames = max_frames
176  )
177  lines <- c(x$message, crayon::bold("Backtrace:"), trace_lines)
178  paste(lines, collapse = "\n")
179}
180
181# as.expectation ----------------------------------------------------------
182
183as.expectation <- function(x, srcref = NULL) {
184  UseMethod("as.expectation", x)
185}
186
187#' @export
188as.expectation.expectation <- function(x, srcref = NULL) {
189  x$srcref <- x$srcref %||% srcref
190  x
191}
192
193#' @export
194as.expectation.error <- function(x, srcref = NULL) {
195
196  if (is.null(x$call)) {
197    header <- paste0("Error: ")
198  } else {
199    header <- paste0("Error in `", deparse1(x$call), "`: ")
200  }
201
202  msg <- paste0(
203    if (!is_simple_error(x)) paste0("<", paste(class(x), collapse = "/"), ">\n"),
204    header, cnd_message(x)
205  )
206
207  expectation("error", msg, srcref, trace = x[["trace"]])
208}
209
210
211is_simple_error <- function(x) {
212  class(x)[[1]] %in% c("simpleError", "rlang_error")
213}
214
215#' @export
216as.expectation.warning <- function(x, srcref = NULL) {
217  expectation("warning", cnd_message(x), srcref, trace = x[["trace"]])
218}
219
220#' @export
221as.expectation.skip <- function(x, ..., srcref = NULL) {
222  expectation("skip", cnd_message(x), srcref, trace = x[["trace"]])
223}
224
225#' @export
226as.expectation.default <- function(x, srcref = NULL) {
227  stop(
228    "Don't know how to convert '", paste(class(x), collapse = "', '"),
229    "' to expectation.", call. = FALSE
230  )
231}
232
233# expectation_type --------------------------------------------------------
234
235expectation_type <- function(exp) {
236  stopifnot(is.expectation(exp))
237  gsub("^expectation_", "", class(exp)[[1]])
238}
239
240expectation_success <- function(exp) expectation_type(exp) == "success"
241expectation_failure <- function(exp) expectation_type(exp) == "failure"
242expectation_error   <- function(exp) expectation_type(exp) == "error"
243expectation_skip    <- function(exp) expectation_type(exp) == "skip"
244expectation_warning <- function(exp) expectation_type(exp) == "warning"
245expectation_broken  <- function(exp) expectation_failure(exp) || expectation_error(exp)
246expectation_ok      <- function(exp) expectation_type(exp) %in% c("success", "warning")
247
248single_letter_summary <- function(x) {
249  switch(expectation_type(x),
250    skip    = colourise("S", "skip"),
251    success = colourise(".", "success"),
252    error   = colourise("E", "error"),
253    failure = colourise("F", "failure"),
254    warning = colourise("W", "warning"),
255    "?"
256  )
257}
258
259expectation_location <- function(x) {
260  if (is.null(x$srcref)) {
261    "???"
262  } else {
263    filename <- attr(x$srcref, "srcfile")$filename
264    if (identical(filename, "")) {
265      paste0("Line ", x$srcref[1])
266    } else {
267      paste0(basename(filename), ":", x$srcref[1], ":", x$srcref[2])
268    }
269  }
270}
271