test-compiled-code.R

#' @keywords internal
#' @rdname run_cpp_tests
#' @export
expect_cpp_tests_pass <- function(package) {
  check_string(package)

  run_testthat_tests <- get_routine(package, "run_testthat_tests")

  output <- ""
  tests_passed <- TRUE

  tryCatch(
    output <- capture_output_lines(
      tests_passed <- .Call(run_testthat_tests, FALSE)
    ),
    error = function(e) {
      cli::cli_warn(
        "Failed to call test entrypoint {.fn {run_testthat_tests}}."
      )
    }
  )

  # Drop first line of output (it's jut a '####' delimiter)
  info <- paste(output[-1], collapse = "\n")

  if (!tests_passed) {
    fail(paste("C++ unit tests:", info, sep = "\n"))
  } else {
    pass()
  }
}

#' Do C++ tests past?
#'
#' Test compiled code in the package `package`. A call to this function will
#' automatically be generated for you in `tests/testthat/test-cpp.R` after
#' calling [use_catch()]; you should not need to manually call this expectation
#' yourself.
#'
#' @param package The name of the package to test.
#' @keywords internal
#' @export
run_cpp_tests <- function(package) {
  check_string(package)

  skip_on_os("solaris")
  check_installed("xml2", "to run run_cpp_tests()")

  run_testthat_tests <- get_routine(package, "run_testthat_tests")

  output <- ""
  catch_error <- NULL

  tryCatch(
    {
      output <- capture_output_lines(
        .Call(run_testthat_tests, TRUE)
      )
    },
    error = function(e) {
      catch_error <<- e
    }
  )

  if (!is.null(catch_error)) {
    context_start("Catch")
    test_that("Catch", {
      fail(conditionMessage(catch_error))
    })
    return()
  }

  output <- paste(output, collapse = "\n")
  contexts <- parse_catch_contexts(output)

  for (context in contexts) {
    context_start(context$name)

    for (test in context$tests) {
      test_that(test$name, {
        for (i in seq_len(test$n_successes)) {
          pass()
        }
        for (failure in test$failures) {
          fail(message = failure$message, srcref = failure$srcref)
        }
        for (exception in test$exceptions) {
          # There is no `fail()` equivalent for an error.
          # We could use `stop()`, but we want to pass through a `srcref`.
          expectation(
            type = "error",
            message = exception$message,
            srcref = exception$srcref
          )
        }
      })
    }
  }
}

parse_catch_contexts <- function(text) {
  xml <- xml2::read_xml(text)

  contexts <- xml2::xml_find_all(xml, "//TestCase")
  contexts <- map(contexts, parse_catch_context)

  contexts
}

parse_catch_context <- function(context) {
  name <- sub(" [|][^|]+$", "", xml2::xml_attr(context, "name"))
  tests <- xml2::xml_find_all(context, "./Section")
  tests <- map(tests, parse_catch_test)
  list(name = name, tests = tests)
}

parse_catch_test <- function(test) {
  name <- xml2::xml_attr(test, "name")

  overall_results <- xml2::xml_find_first(test, "./OverallResults")
  n_successes <- as.integer(xml2::xml_attr(overall_results, "successes"))

  failures <- xml2::xml_find_all(test, "./Expression")
  failures <- map(failures, parse_catch_failure)

  exceptions <- xml2::xml_find_all(test, "./Exception")
  exceptions <- map(exceptions, parse_catch_exception)

  list(
    name = name,
    n_successes = n_successes,
    failures = failures,
    exceptions = exceptions
  )
}

parse_catch_failure <- function(failure) {
  type <- switch(
    xml2::xml_attr(failure, "type"),
    "CATCH_CHECK_FALSE" = "isn't false.",
    "CATCH_CHECK_THROWS" = "did not throw an exception.",
    "CATCH_CHECK_THROWS_AS" = "threw an exception with unexpected type.",
    "isn't true."
  )

  message <- xml2::xml_find_first(failure, "Original")
  message <- xml2::xml_text(message, trim = TRUE)
  message <- paste(message, type)

  filename <- xml2::xml_attr(failure, "filename")
  line <- xml2::xml_attr(failure, "line")
  srcref <- srcref(
    srcfile(file.path("src", filename)),
    c(line, line, 1, 1)
  )

  list(
    message = message,
    srcref = srcref
  )
}

parse_catch_exception <- function(exception) {
  message <- xml2::xml_text(exception, trim = TRUE)

  filename <- xml2::xml_attr(exception, "filename")
  line <- xml2::xml_attr(exception, "line")
  srcref <- srcref(
    srcfile(file.path("src", filename)),
    c(line, line, 1, 1)
  )

  list(
    message = message,
    srcref = srcref
  )
}

#' Use Catch for C++ unit testing
#'
#' Add the necessary infrastructure to enable C++ unit testing
#' in \R packages with [Catch](https://github.com/catchorg/Catch2) and
#' `testthat`.
#'
#' Calling `use_catch()` will:
#'
#' 1. Create a file `src/test-runner.cpp`, which ensures that the
#'    `testthat` package will understand how to run your package's
#'    unit tests,
#'
#' 2. Create an example test file `src/test-example.cpp`, which
#'    showcases how you might use Catch to write a unit test,
#'
#' 3. Add a test file `tests/testthat/test-cpp.R`, which ensures that
#'    `testthat` will run your compiled tests during invocations of
#'    `devtools::test()` or `R CMD check`, and
#'
#' 4. Create a file `R/catch-routine-registration.R`, which ensures that
#'    \R will automatically register this routine when
#'    `tools::package_native_routine_registration_skeleton()` is invoked.
#'
#' You will also need to:
#'
#' * Add xml2 to Suggests, with e.g. `usethis::use_package("xml2", "Suggests")`
#' * Add testthat to LinkingTo, with e.g.
#'   `usethis::use_package("testthat", "LinkingTo")`
#'
#' C++ unit tests can be added to C++ source files within the
#' `src` directory of your package, with a format similar
#' to \R code tested with `testthat`. Here's a simple example
#' of a unit test written with `testthat` + Catch:
#'
#' \preformatted{
#' context("C++ Unit Test") {
#'   test_that("two plus two is four") {
#'     int result = 2 + 2;
#'     expect_true(result == 4);
#'   }
#' }
#' }
#'
#' When your package is compiled, unit tests alongside a harness
#' for running these tests will be compiled into your \R package,
#' with the C entry point `run_testthat_tests()`. `testthat`
#' will use that entry point to run your unit tests when detected.
#'
#' @section Functions:
#'
#' All of the functions provided by Catch are
#' available with the `CATCH_` prefix -- see
#' [here](https://github.com/catchorg/Catch2/blob/master/docs/assertions.md)
#' for a full list. `testthat` provides the
#' following wrappers, to conform with `testthat`'s
#' \R interface:
#'
#' \tabular{lll}{
#' \strong{Function} \tab \strong{Catch} \tab \strong{Description} \cr
#' `context` \tab `CATCH_TEST_CASE` \tab The context of a set of tests. \cr
#' `test_that` \tab `CATCH_SECTION` \tab A test section. \cr
#' `expect_true` \tab `CATCH_CHECK` \tab Test that an expression evaluates to `TRUE`. \cr
#' `expect_false` \tab `CATCH_CHECK_FALSE` \tab Test that an expression evaluates to `FALSE`. \cr
#' `expect_error` \tab `CATCH_CHECK_THROWS` \tab Test that evaluation of an expression throws an exception. \cr
#' `expect_error_as` \tab `CATCH_CHECK_THROWS_AS` \tab Test that evaluation of an expression throws an exception of a specific class. \cr
#' }
#'
#' In general, you should prefer using the `testthat`
#' wrappers, as `testthat` also does some work to
#' ensure that any unit tests within will not be compiled or
#' run when using the Solaris Studio compilers (as these are
#' currently unsupported by Catch). This should make it
#' easier to submit packages to CRAN that use Catch.
#'
#' @section Symbol Registration:
#'
#' If you've opted to disable dynamic symbol lookup in your
#' package, then you'll need to explicitly export a symbol
#' in your package that `testthat` can use to run your unit
#' tests. `testthat` will look for a routine with one of the names:
#'
#' \preformatted{
#'     C_run_testthat_tests
#'     c_run_testthat_tests
#'     run_testthat_tests
#' }
#'
#' Assuming you have `useDynLib(<pkg>, .registration = TRUE)` in your package's
#' `NAMESPACE` file, this implies having routine registration code of the form:
#'
#' ```
#' // The definition for this function comes from the file 'src/test-runner.cpp',
#' // which is generated via `testthat::use_catch()`.
#' extern SEXP run_testthat_tests();
#'
#' static const R_CallMethodDef callMethods[] = {
#'   // other .Call method definitions,
#'   {"run_testthat_tests", (DL_FUNC) &run_testthat_tests, 0},
#'   {NULL, NULL, 0}
#' };
#'
#' void R_init_<pkg>(DllInfo* dllInfo) {
#'   R_registerRoutines(dllInfo, NULL, callMethods, NULL, NULL);
#'   R_useDynamicSymbols(dllInfo, FALSE);
#' }
#' ```
#'
#' replacing `<pkg>` above with the name of your package, as appropriate.
#'
#' See [Controlling Visibility](https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Controlling-visibility)
#' and [Registering Symbols](https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Registering-symbols)
#' in the **Writing R Extensions** manual for more information.
#'
#' @section Advanced Usage:
#'
#' If you'd like to write your own Catch test runner, you can
#' instead use the `testthat::catchSession()` object in a file
#' with the form:
#'
#' \preformatted{
#' #define TESTTHAT_TEST_RUNNER
#' #include <testthat.h>
#'
#' void run()
#' {
#'     Catch::Session& session = testthat::catchSession();
#'     // interact with the session object as desired
#' }
#' }
#'
#' This can be useful if you'd like to run your unit tests
#' with custom arguments passed to the Catch session.
#'
#' @param dir The directory containing an \R package.
#'
#' @section Standalone Usage:
#'
#' If you'd like to use the C++ unit testing facilities provided
#' by Catch, but would prefer not to use the regular `testthat`
#' \R testing infrastructure, you can manually run the unit tests
#' by inserting a call to:
#'
#' \preformatted{
#' .Call("run_testthat_tests", PACKAGE = <pkgName>)
#' }
#'
#' as necessary within your unit test suite.
#'
#' @export
#' @seealso [Catch](https://github.com/catchorg/Catch2/blob/master/docs/assertions.md),
#'   the library used to enable C++ unit testing.
use_catch <- function(dir = getwd()) {
  desc_path <- file.path(dir, "DESCRIPTION")
  if (!file.exists(desc_path)) {
    cli::cli_abort("No DESCRIPTION file at path {.path {desc_path}}.")
  }

  desc <- read.dcf(desc_path, all = TRUE)
  pkg <- desc$Package
  if (!nzchar(pkg)) {
    cli::cli_abort(
      "No {.field Package} field in DESCRIPTION file {.path {desc_path}}."
    )
  }

  src_dir <- file.path(dir, "src")
  if (!file.exists(src_dir) && !dir.create(src_dir)) {
    cli::cli_abort("Failed to create {.path src/} directory {.path {src_dir}}.")
  }

  test_runner_path <- file.path(src_dir, "test-runner.cpp")

  # Copy the test runner.
  success <- file.copy(
    system.file(package = "testthat", "resources", "test-runner.cpp"),
    test_runner_path,
    overwrite = TRUE
  )

  if (!success) {
    cli::cli_abort(
      "Failed to copy {.file test-runner.cpp} to {.path {src_dir}}."
    )
  }

  # Copy the test example.
  success <- file.copy(
    system.file(package = "testthat", "resources", "test-example.cpp"),
    file.path(src_dir, "test-example.cpp"),
    overwrite = TRUE
  )

  if (!success) {
    cli::cli_abort(
      "Failed to copy {.file test-example.cpp} to {.path {src_dir}}."
    )
  }

  # Copy the 'test-cpp.R' file.
  test_dir <- file.path(dir, "tests", "testthat")
  if (!file.exists(test_dir) && !dir.create(test_dir, recursive = TRUE)) {
    cli::cli_abort(
      "Failed to create {.path tests/testthat/} directory {.path {test_dir}}."
    )
  }

  template_file <- system.file(package = "testthat", "resources", "test-cpp.R")
  contents <- readChar(template_file, file.info(template_file)$size, TRUE)
  transformed <- sprintf(contents, pkg)
  output_path <- file.path(test_dir, "test-cpp.R")
  cat(transformed, file = output_path)

  # Copy the 'test-runner.R file.
  template_file <- system.file(
    package = "testthat",
    "resources",
    "catch-routine-registration.R"
  )
  contents <- readChar(template_file, file.info(template_file)$size, TRUE)
  transformed <- sprintf(contents, pkg)
  output_path <- file.path(dir, "R", "catch-routine-registration.R")
  cat(transformed, file = output_path)

  cli::cli_inform(c(
    v = "Added C++ unit testing infrastructure.",
    i = "Please ensure you have {.field LinkingTo: testthat} in your DESCRIPTION.",
    i = "Please ensure you have {.field Suggests: xml2} in your DESCRIPTION."
  ))
}

get_routine <- function(package, routine) {
  # check to see if the package has explicitly exported
  # the associated routine (check common prefixes as we
  # don't necessarily have access to the NAMESPACE and
  # know what the prefix is)
  namespace <- asNamespace(package)
  prefixes <- c("C_", "c_", "C", "c", "_", "")
  for (prefix in prefixes) {
    name <- paste(prefix, routine, sep = "")
    if (exists(name, envir = namespace)) {
      symbol <- get(name, envir = namespace)
      if (inherits(symbol, "NativeSymbolInfo")) {
        return(symbol)
      }
    }
  }

  # otherwise, try to resolve the symbol dynamically
  for (prefix in prefixes) {
    name <- paste(prefix, routine, sep = "")
    resolved <- tryCatch(
      getNativeSymbolInfo(routine, PACKAGE = package),
      error = function(e) NULL
    )
    if (inherits(resolved, "NativeSymbolInfo")) {
      return(resolved)
    }
  }

  # if we got here, we failed to find the symbol -- throw an error
  cli::cli_abort(
    "Failed to locate routine {.code {routine}} in package {.pkg {package}}."
  )
}

(function() {
  .Call(run_testthat_tests, TRUE)
})