Improve print method (#346)

Fixes #344

NEWS.md

@@ -1,5 +1,7 @@
 # S7 (development version)
 
+* Classes get a more informative print method (#346).
+
 * External methods are now registered using an attribute of the S3 methods 
   table rather than an element of that environment. This prevents a warning
   being generated during the "code/documentation mismatches" check in

R/class.R

@@ -180,9 +180,19 @@ print.S7_class <- function(x, ...) {
   }
 
   cat(
-    sprintf("<S7_class>\n@ name  :  %s\n@ parent: %s\n@ properties:\n%s",
-      x@name,
+    sprintf(
+      paste0(
+        "%s%s class\n",
+        "@ parent     : %s\n",
+        "@ constructor: %s\n",
+        "@ validator  : %s\n",
+        "@ properties :\n%s"
+      ),
+      class_desc(x),
+      if (x@abstract) " abstract" else "",
       class_desc(x@parent),
+      show_function(x@constructor, constructor = TRUE),
+      if (!is.null(x@validator)) show_function(x@validator) else "<NULL>",
       prop_fmt
     ),
     sep = ""

R/utils.R

@@ -108,15 +108,32 @@ check_function <- function(f, args, arg = deparse(substitute(f))) {
     stop(msg, call. = FALSE)
   }
 }
-show_args <- function(x, name = "function") {
+
+show_function <- function(x, constructor = FALSE) {
+  args <- formals(x)
+
+  if (constructor) {
+    args <- lapply(args, function(x) {
+      if (identical(x, quote(class_missing))) {
+        quote(expr = )
+      } else {
+        x
+      }
+    })
+  }
+
+  show_args(args, suffix = " {...}")
+}
+
+show_args <- function(x, name = "function", suffix = "") {
   if (length(x) == 0) {
     args <- ""
   } else {
     val <- vcapply(x, deparse1)
     args <- paste0(names(x), ifelse(val == "", "", " = "), val, collapse = ", ")
   }
 
-  paste0(name, "(", args, ")")
+  paste0(name, "(", args, ")", suffix)
 }
 
 # For older versions of R ----------------------------------------------------

tests/testthat/_snaps/class.md

@@ -3,10 +3,11 @@
     Code
       foo2
     Output
-      <S7_class>
-      @ name  :  foo2
-      @ parent: <foo1>
-      @ properties:
+      <foo2> class
+      @ parent     : <foo1>
+      @ constructor: function(x, y) {...}
+      @ validator  : <NULL>
+      @ properties :
        $ x: <integer>
        $ y: <integer>
     Code
@@ -40,6 +41,17 @@
       List of 1
        $ : <foo2/foo1/S7_object> constructor
 
+# S7 classes: prints @package and @abstract details
+
+    Code
+      foo
+    Output
+      <S7::foo> abstract class
+      @ parent     : <S7_object>
+      @ constructor: function() {...}
+      @ validator  : <NULL>
+      @ properties :
+
 # S7 classes: checks inputs
 
     Code

tests/testthat/_snaps/property.md

@@ -96,10 +96,11 @@
     Code
       my_class
     Output
-      <S7_class>
-      @ name  :  my_class
-      @ parent: <S7_object>
-      @ properties:
+      <my_class> class
+      @ parent     : <S7_object>
+      @ constructor: function(anything, null, base, S3, S4, S7, S7_union) {...}
+      @ validator  : <NULL>
+      @ properties :
        $ anything: <ANY>                 
        $ null    : <NULL>                
        $ base    : <integer>             

tests/testthat/test-class.R

@@ -23,6 +23,11 @@ describe("S7 classes", {
     })
   })
 
+  it("prints @package and @abstract details", {
+    foo <- new_class("foo", package = "S7", abstract = TRUE)
+    expect_snapshot(foo)
+  })
+
   it("checks inputs", {
     expect_snapshot(error = TRUE, {
       new_class(1)