Implement R7_inherits() and check_R7_inherits()

Fixes #193

NAMESPACE

@@ -32,8 +32,10 @@ export("props<-")
 export(R7_class)
 export(R7_data)
 export(R7_dispatch)
+export(R7_inherits)
 export(R7_object)
 export(as_class)
+export(check_R7_inherits)
 export(class_any)
 export(class_atomic)
 export(class_character)

NEWS.md

@@ -1,5 +1,7 @@
 # R7 0.0.0.9000
 
+* New `R7_inherits()` and `check_R7_inherits()` (#193)
+
 * `new_class()` can create abstract classes (#199).
 
 * `method_call()` is now `R7_dispatch()` (#200).

R/inherits.R

@@ -0,0 +1,34 @@
+#' Does this object inherit from an R7 class?
+#'
+#' * `R7_inherits()` returns `TRUE` or `FALSE`
+#' * `check_R7_inherits()` throws an error.
+#'
+#' @param x An object
+#' @param class An R7 class
+#' @param arg Argument name used in error message.
+#' @export
+#' @examples
+#' foo1 <- new_class("foo1")
+#' foo2 <- new_class("foo2")
+#'
+#' R7_inherits(foo1(), foo1)
+#' check_R7_inherits(foo1(), foo1)
+#'
+#' R7_inherits(foo1(), foo2)
+#' try(check_R7_inherits(foo1(), foo2))
+R7_inherits <- function(x, class) {
+  if (!inherits(class, "R7_class")) {
+    stop("`class` is not an <R7_class>")
+  }
+
+  inherits(x, "R7_object") && inherits(x, R7_class_name(class))
+}
+
+#' @export
+#' @rdname R7_inherits
+check_R7_inherits <- function(x, class, arg = deparse(substitute(x))) {
+  if (!R7_inherits(x, class)) {
+    stop(sprintf("`%s` is not an %s", arg, class_desc(class)), call. = FALSE)
+  }
+  invisible()
+}

tests/testthat/_snaps/inherits.md

@@ -0,0 +1,16 @@
+# checks that input is a class
+
+    Code
+      R7_inherits(1:10, "x")
+    Error <simpleError>
+      `class` is not an <R7_class>
+
+# throws informative error
+
+    Code
+      foo1 <- new_class("foo1")
+      foo2 <- new_class("foo2")
+      check_R7_inherits(foo1(), foo2)
+    Error <simpleError>
+      `foo1()` is not an <foo2>
+

tests/testthat/test-inherits.R

@@ -0,0 +1,20 @@
+test_that("it works", {
+  foo1 <- new_class("foo1")
+  foo2 <- new_class("foo2", parent = foo1)
+
+  expect_true(R7_inherits(foo1(), foo1))
+  expect_true(R7_inherits(foo2(), foo1))
+  expect_false(R7_inherits(foo1(), foo2))
+})
+
+test_that("checks that input is a class", {
+  expect_snapshot(R7_inherits(1:10, "x"), error = TRUE)
+})
+
+test_that("throws informative error", {
+  expect_snapshot(error = TRUE, {
+    foo1 <- new_class("foo1")
+    foo2 <- new_class("foo2")
+    check_R7_inherits(foo1(), foo2)
+  })
+})