WIP: Dedicated reporter (#7)

* Package infrastructure

* These files keep updating, not sure what to do about them

* Tweak DESCRIPTION

* Change license to MIT

* Use testthat

* Rename

* Import infrastructure from testthat

* Add TAP reporter as base

* Tweak test infrastructure

* Avoid teardown for now

* Working test

* Fix R CMD check

* Rename reporter

* Add first JSON output

* More JSON

* No contexts

* Start and end test

* Start and end reporter

* Add result

* File output, remove TAP

* Remove context

* Document

* Revert "These files keep updating, not sure what to do about them"

This reverts commit c39265a.

src/R/.Rbuildignore

@@ -0,0 +1,3 @@
+^R\.Rproj$
+^\.Rproj\.user$
+^LICENSE\.md$

src/R/.gitignore

@@ -0,0 +1 @@
+.Rproj.user

src/R/DESCRIPTION

@@ -0,0 +1,21 @@
+Package: rtestexplorer
+Title: Test Reporters For R Test Explorer
+Version: 0.0.0.9000
+Date: 2021-03-23
+Authors@R: 
+    person(given = "Kirill",
+           family = "Müller",
+           role = c("aut", "cre"),
+           email = "krlmlr+r@mailbox.org",
+           comment = c(ORCID = "0000-0002-1416-3412"))
+Description: A test reporter for the R Test Explorer.
+License: MIT + file LICENSE
+Encoding: UTF-8
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.1.1.9001
+Imports: 
+    rlang,
+    testthat (>= 3.0.0),
+    withr
+Config/testthat/edition: 3

src/R/LICENSE

@@ -0,0 +1,3 @@
+YEAR: 2021
+COPYRIGHT HOLDER: rtestexplorer authors
+COPYRIGHT HOLDER: Hadley Wickham; RStudio

src/R/LICENSE.md

@@ -0,0 +1,23 @@
+# MIT License
+
+Copyright (c) 2021 rtestexplorer authors
+
+Copyright (c) 2013-2019 Hadley Wickham; RStudio
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

src/R/NAMESPACE

@@ -0,0 +1,4 @@
+# Generated by roxygen2: do not edit by hand
+
+export(VsCodeReporter)
+import(testthat)

src/R/R/expect.R

@@ -0,0 +1,20 @@
+expect_snapshot_reporter <- function(reporter, path = test_path("reporters/tests.R")) {
+  withr::local_rng_version("3.3")
+  withr::with_seed(1014, {
+    expect_snapshot_output(
+      with_reporter(
+        reporter,
+        test_one_file(path)
+      )
+    )
+  })
+}
+
+test_one_file <- function(path, env = test_env(), wrap = TRUE) {
+  reporter <- testthat::get_reporter()
+
+  reporter$start_file(path)
+  source_file(path, rlang::child_env(env), wrap = wrap)
+  reporter$end_context_if_started()
+  reporter$end_file()
+}

src/R/R/import.R

@@ -0,0 +1,2 @@
+#' @import testthat
+NULL

src/R/R/reporter-vscode.R

@@ -0,0 +1,98 @@
+#' Test reporter: VS Code format.
+#'
+#' This reporter will output results in a format understood by the
+#' [R Test Explorer](https://github.com/meakbiyik/vscode-r-test-adapter).
+#'
+#' @export
+VsCodeReporter <- R6::R6Class("VsCodeReporter",
+  inherit = Reporter,
+  private = list(
+    filename = NULL
+  ),
+  public = list(
+    suite_name = NULL,
+
+    initialize = function(suite_name, ...) {
+      super$initialize(...)
+      self$suite_name <- suite_name
+      private$filename <- NULL
+      self$capabilities$parallel_support <- TRUE
+      # FIXME: self$capabilities$parallel_updates <- TRUE
+    },
+
+    start_reporter = function() {
+      self$cat_json(list(type = "start_reporter", tests = list(self$suite_name)))
+    },
+
+    start_file = function(filename) {
+      self$cat_json(list(type = "start_file", filename = filename))
+      private$filename <- filename
+    },
+
+    start_test = function(context, test) {
+      self$cat_json(list(type = "start_test", test = test))
+    },
+
+    add_result = function(context, test, result) {
+      self$cat_json(list(
+        type = "add_result",
+        context = context,
+        test = test,
+        result = expectation_type(result),
+        message = exp_message(result),
+        location = expectation_location(result)
+      ))
+    },
+
+    end_test = function(context, test) {
+      self$cat_json(list(type = "end_test", test = test))
+    },
+
+    end_file = function() {
+      self$cat_json(list(type = "end_file", filename = private$filename))
+      private$filename <- NULL
+    },
+
+    end_reporter = function() {
+      self$cat_json(list(type = "end_reporter", tests = list(self$suite_name)))
+    },
+
+    cat_json = function(x) {
+      self$cat_line(jsonlite::toJSON(x, auto_unbox = TRUE))
+    }
+  )
+)
+
+expectation_type <- function(exp) {
+  stopifnot(is.expectation(exp))
+  gsub("^expectation_", "", class(exp)[[1]])
+}
+
+expectation_success <- function(exp) expectation_type(exp) == "success"
+expectation_failure <- function(exp) expectation_type(exp) == "failure"
+expectation_error   <- function(exp) expectation_type(exp) == "error"
+expectation_skip    <- function(exp) expectation_type(exp) == "skip"
+expectation_warning <- function(exp) expectation_type(exp) == "warning"
+expectation_broken  <- function(exp) expectation_failure(exp) || expectation_error(exp)
+expectation_ok      <- function(exp) expectation_type(exp) %in% c("success", "warning")
+
+exp_message <- function(x) {
+  if (expectation_error(x)) {
+    paste0("Error: ", x$message)
+  } else {
+    x$message
+  }
+}
+
+expectation_location <- function(x) {
+  if (is.null(x$srcref)) {
+    "???"
+  } else {
+    filename <- attr(x$srcref, "srcfile")$filename
+    if (identical(filename, "")) {
+      paste0("Line ", x$srcref[1])
+    } else {
+      paste0(basename(filename), ":", x$srcref[1], ":", x$srcref[2])
+    }
+  }
+}

src/R/tests/testthat.R

@@ -0,0 +1,4 @@
+library(testthat)
+library(rtestexplorer)
+
+test_check("rtestexplorer")

src/R/tests/testthat/_snaps/reporter-vscode.md

@@ -0,0 +1,31 @@
+# reporter works
+
+    {"type":"start_reporter","tests":["suite_name"]}
+    {"type":"start_file","filename":"reporters/tests.R"}
+    {"type":"start_test","test":"Success"}
+    {"type":"add_result","context":{},"test":"Success","result":"success","message":"Success has been forced","location":"tests.R:2:3"}
+    {"type":"end_test","test":"Success"}
+    {"type":"start_test","test":"Failure:1"}
+    {"type":"add_result","context":{},"test":"Failure:1","result":"failure","message":"FALSE is not TRUE\n\n`actual`:   FALSE\n`expected`: TRUE ","location":"tests.R:6:3"}
+    {"type":"end_test","test":"Failure:1"}
+    {"type":"start_test","test":"Failure:2a"}
+    {"type":"add_result","context":{},"test":"Failure:2a","result":"failure","message":"FALSE is not TRUE\n\n`actual`:   FALSE\n`expected`: TRUE ","location":"tests.R:11:3"}
+    {"type":"end_test","test":"Failure:2a"}
+    {"type":"start_test","test":"Error:1"}
+    {"type":"add_result","context":{},"test":"Error:1","result":"error","message":"Error: stop","location":"tests.R:15:3"}
+    {"type":"end_test","test":"Error:1"}
+    {"type":"start_test","test":"errors get tracebacks"}
+    {"type":"add_result","context":{},"test":"errors get tracebacks","result":"error","message":"Error: !","location":"tests.R:23:3"}
+    {"type":"end_test","test":"errors get tracebacks"}
+    {"type":"start_test","test":"explicit skips are reported"}
+    {"type":"add_result","context":{},"test":"explicit skips are reported","result":"skip","message":"Reason: skip","location":"tests.R:27:3"}
+    {"type":"end_test","test":"explicit skips are reported"}
+    {"type":"start_test","test":"empty tests are implicitly skipped"}
+    {"type":"add_result","context":{},"test":"empty tests are implicitly skipped","result":"skip","message":"Reason: empty test","location":"tests.R:30:1"}
+    {"type":"end_test","test":"empty tests are implicitly skipped"}
+    {"type":"start_test","test":"warnings get backtraces"}
+    {"type":"add_result","context":{},"test":"warnings get backtraces","result":"warning","message":"def","location":"tests.R:37:3"}
+    {"type":"end_test","test":"warnings get backtraces"}
+    {"type":"end_file","filename":"reporters/tests.R"}
+    {"type":"end_reporter","tests":["suite_name"]}
+