Syntax sugar for unions

Fixes #224

NAMESPACE

@@ -7,6 +7,13 @@ S3method("[",S7_object)
 S3method("[<-",S7_object)
 S3method("[[",S7_object)
 S3method("[[<-",S7_object)
+S3method("|",ClassUnionRepresentation)
+S3method("|",S7_S3_class)
+S3method("|",S7_base_class)
+S3method("|",S7_class)
+S3method("|",S7_union)
+S3method("|",classGeneratorFunction)
+S3method("|",classRepresentation)
 S3method(Ops,S7_object)
 S3method(c,S7_class)
 S3method(print,S7_S3_class)

NEWS.md

@@ -2,6 +2,8 @@
 
 ## March 2023
 
+* Can use `|` to create unions from S7 classes (#224).
+
 * Can no longer subclass an environment via `class_environment` because we
   need to think the consequences of this behaviour through more fully (#253).
 

R/union.R

@@ -1,14 +1,15 @@
 #' Define a class union
 #'
 #' @description
-#' A class union represents a list of possible classes. It can be used in two
+#' A class union represents a list of possible classes. You can create it
+#' with `new_union(a, b, c)` or `a | b | c`. Unions can be used in two
 #' places:
 #'
 #' * To allow a property to be one of a set of classes,
-#'   `new_property(new_union("integer", Range))`.
+#'   `new_property(class_integer | Range)`.
 #'
 #' * As a convenient short-hand to define methods for multiple classes.
-#'   `method(foo, new_union(X, Y)) <- f` is short-hand for
+#'   `method(foo, X | Y) <- f` is short-hand for
 #'   `method(foo, X) <- f; method(foo, Y) <- foo`
 #'
 #' S7 includes built-in unions for "numeric" (integer and double vectors),
@@ -21,6 +22,8 @@
 #' @examples
 #' logical_or_character <- new_union(class_logical, class_character)
 #' logical_or_character
+#' # or with shortcut syntax
+#' logical_or_character <- class_logical | class_character
 #'
 #' Foo <- new_class("Foo", properties = list(x = logical_or_character))
 #' Foo(x = TRUE)
@@ -41,6 +44,23 @@ new_union <- function(...) {
   out
 }
 
+#' @export
+`|.S7_class` <- function(e1, e2) {
+  new_union(e1, e2)
+}
+#' @export
+`|.S7_union` <- `|.S7_class`
+#' @export
+`|.S7_base_class` <- `|.S7_class`
+#' @export
+`|.S7_S3_class` <- `|.S7_class`
+#' @export
+`|.classGeneratorFunction` <- `|.S7_class`
+#' @export
+`|.ClassUnionRepresentation` <- `|.S7_class`
+#' @export
+`|.classRepresentation` <- `|.S7_class`
+
 is_union <- function(x) inherits(x, "S7_union")
 
 #' @export

tests/testthat/test-union.R

@@ -35,7 +35,26 @@ test_that("base unions display as expected", {
 })
 
 test_that("can construct from S3 and S4 classes", {
-  S4_union <- methods::setClass("S4_union")
+  S4_union <- methods::setClass("S4_union", where = globalenv())
+  on.exit(S4_remove_classes("S4_union"))
+
   u <- new_union(class_factor, S4_union)
   expect_equal(u$classes, list(class_factor, getClass("S4_union")))
 })
+
+test_that("can construct with |", {
+  foo <- new_class("foo")
+  Foo1 <- setClass("Foo1", slots = list("x" = "numeric"), where = globalenv())
+  Foo2 <- setClass("Foo2", slots = list("x" = "numeric"), where = globalenv())
+  Foo3 <- setClassUnion("Foo3", c("Foo1", "Foo2"), where = globalenv())
+  on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3")))
+
+  expect_equal(class_integer | class_double, class_numeric)
+  expect_equal(class_integer | class_numeric, class_numeric)
+  expect_equal(class_integer | class_factor, new_union(class_integer, class_factor))
+  expect_equal(class_integer | foo, new_union(class_integer, foo))
+  expect_equal(class_integer | Foo1, new_union(class_integer, Foo1))
+  expect_equal(class_integer | getClass("Foo1"), new_union(class_integer, Foo1))
+  expect_equal(class_integer | Foo3, new_union(class_integer, Foo3))
+  expect_equal(class_integer | getClass("Foo3"), new_union(class_integer, Foo3))
+})