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