Add #:implements/inits for Class types

Allows some Class types to be written more concisely.

pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl

@@ -252,6 +252,7 @@ additional provides all other bindings from @racketmodname[racket/class].
                                        (field name+type ...)
                                        (augment name+type ...)
                                        (code:line #:implements type-alias-id)
+                                       (code:line #:implements/inits inits-id)
                                        (code:line #:row-var row-var-id)]
                     [init-type name+type
                                [id type #:optional]]
@@ -282,7 +283,8 @@ additional provides all other bindings from @racketmodname[racket/class].
 
   The order of initialization arguments in the type is significant, because
   it determines the types of by-position arguments for use with
-  @racket[make-object] and @racket[instantiate].
+  @racket[make-object] and @racket[instantiate]. A given @racket[Class] type
+  may also only contain a single @racket[init-rest] clause.
 
   @ex[
     (define drink%
@@ -300,6 +302,15 @@ additional provides all other bindings from @racketmodname[racket/class].
   for a subclass to include parts of its parent class type. The initialization argument
   types of the parent, however, are @emph{not} included because a subclass does not necessarily
   share the same initialization arguments as its parent class.
+
+  Initialization argument types can be included from the parent by providing
+  @racket[inits-id] with the @racket[#:implements/inits] keyword. This is identical
+  to the @racket[#:implements] clause except for the initialization argument
+  behavior. Only a single @racket[#:implements/inits] clause may be provided for
+  a single @racket[Class] type. The initialization arguments copied from the parent
+  type are appended to the initialization arguments specified via the @racket[init]
+  and @racket[init-field] clauses.
+
   Multiple @racket[#:implements] clauses may be provided for a single class
   type.
 

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt

@@ -731,8 +731,14 @@
   (syntax-parse stx
     [(kw (~var clause (class-type-clauses parse-type)))
      (add-disappeared-use #'kw)
-     (define parent-stxs (stx->list #'clause.extends-types))
+     (define parent-stxs (stx->list #'clause.implements))
-     (define parent-types (map parse-type parent-stxs))
+     (define parent/init-stx (attribute clause.implements/inits))
+     (define parent/init-type (and parent/init-stx (parse-type parent/init-stx)))
+     (define parent-types
+       (let ([types (map parse-type parent-stxs)])
+         (if parent/init-stx
+             (cons parent/init-type types)
+             types)))
      (define given-inits (attribute clause.inits))
      (define given-fields (attribute clause.fields))
      (define given-methods (attribute clause.methods))
@@ -755,7 +761,7 @@
            ;; Only proceed to create a class type when the parsing
            ;; process isn't looking for recursive type alias references.
            ;; (otherwise the merging process will error)
-           [(or (null? parent-stxs)
+           [(or (and (null? parent-stxs) (not parent/init-stx))
                 (not (current-referenced-aliases)))
 
             (check-function-types given-methods)
@@ -768,7 +774,8 @@
                          [methods given-methods]
                          [augments given-augments])
                   ([parent-type parent-types]
-                   [parent-stx  parent-stxs])
+                   [parent-stx  (append (or (list parent/init-stx) null)
+                                        parent-stxs)])
                 (merge-with-parent-type row-var parent-type parent-stx
                                         fields methods augments)))
 
@@ -780,8 +787,15 @@
               (check-constraints methods (caddr constraints))
               (check-constraints augments (cadddr constraints)))
 
+            ;; For the #:implements/inits entry, put the inits into the type
+            ;; as well. They are appended at the end to match the runtime behavior
+            ;; of init arguments.
+            (define parent-inits (get-parent-inits parent/init-type))
+
             (define class-type
-              (make-Class row-var given-inits fields methods augments given-init-rest))
+              (make-Class row-var
+                          (append given-inits parent-inits)
+                          fields methods augments given-init-rest))
 
             class-type]
            [else
@@ -809,12 +823,26 @@
             (set-box! alias-box (cons (current-type-alias-name)
                                       (unbox alias-box)))
             (define class-box (current-referenced-class-parents))
-            (set-box! class-box (append parent-stxs (unbox class-box)))
+            (set-box! class-box (append (if parent/init-stx
+                                            (cons parent/init-stx parent-stxs)
+                                            parent-stxs)
+                                        (unbox class-box)))
             ;; Ok to return Error here, since this type will
             ;; get reparsed in another pass
             (make-Error)
             ])]))
 
+;; get-parent-inits : (U Type #f) -> Inits
+;; Extract the init arguments out of a parent class type
+(define (get-parent-inits parent)
+  (cond [(not parent) null]
+        [else
+         (define resolved (resolve parent))
+         (match resolved
+           [(Class: _ inits _ _ _ _) inits]
+           [_ (parse-error "expected a class type for #:implements/inits clause"
+                           "given" resolved)])]))
+
 ;; check-function-types : Dict<Name, Type> -> Void
 ;; ensure all types recorded in the dictionary are function types
 (define (check-function-types method-types)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt

@@ -211,11 +211,12 @@
 ;; dependencies
 (define-splicing-syntax-class (class-type-clauses parse-type)
   #:description "Class type clause"
-  #:attributes (row-var extends-types
+  #:attributes (row-var implements implements/inits
                 inits fields methods augments init-rest)
   #:literal-sets (class-type-literals)
   (pattern (~seq (~or (~optional (~seq #:row-var row-var:id))
-                      (~seq #:implements extends-type:id)
+                      (~seq #:implements implements-id:id)
+                      (~optional (~seq #:implements/inits implements/inits:id))
                       (~optional ((~or init-rest untyped:init-rest)
                                   init-rest-type:expr))
                       (~var clause (type-clause parse-type)))
@@ -226,7 +227,7 @@
            #:attr augments (apply append (attribute clause.augment-entries))
            #:attr init-rest (and (attribute init-rest-type)
                                  (parse-type (attribute init-rest-type)))
-           #:with extends-types #'(extends-type ...)
+           #:with implements #'(implements-id ...)
            #:fail-when
            (check-duplicate (map first (attribute inits)))
            "duplicate init or init-field clause"

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt

@@ -1572,4 +1572,64 @@
                (define/augment (m x) (inner 'bar-m m x))
                (define/augment (o x y) (inner 'bar-o o x y))))
            (void))
-         -Void]))
+         -Void]
+   ;; Test implements clauses
+   [tc-e (let ()
+           (define-type-alias A% (Class [foo (-> Void)]))
+           (define-type-alias B% (Class #:implements A% [bar (-> Void)]))
+           (: b% B%)
+           (define b% (class object%
+                        (super-new)
+                        (define/public (foo) (void))
+                        (define/public (bar) (void))))
+           (new b%))
+         (-object #:method ([foo (t:-> -Void)] [bar (t:-> -Void)]))]
+   [tc-err (let ()
+             (define-type-alias A% (Class [foo (-> Void)]))
+             (define-type-alias B% (Class #:implements A% [bar (-> Void)]))
+             (: b% B%)
+             (define b% (class object%
+                          (super-new)
+                          (define/public (bar) (void))))
+             (error "foo"))
+           #:msg "type mismatch.*required public method"]
+   [tc-e (let ()
+           (define-type-alias A% (Class (init [y Symbol])))
+           (define-type-alias B% (Class #:implements/inits A% (init [x String])))
+           (: b% B%)
+           (define b% (class object%
+                        (super-new)
+                        (init x y)))
+           (make-object b% "foo" 'bar)
+           (void))
+        -Void]
+   [tc-e (let ()
+           (define-type-alias A% (Class (init [y Symbol])))
+           (define-type-alias B% (Class [m (-> Void)]))
+           (define-type-alias C% (Class #:implements/inits A%
+                                        #:implements B%
+                                        (init [x String])))
+           (: c% C%)
+           (define c% (class object%
+                        (super-new)
+                        (define/public (m) (void))
+                        (init x y)))
+           (make-object c% "foo" 'bar)
+           (void))
+        -Void]
+   [tc-err (let ()
+             (define-type-alias A% (Class (init [y String])))
+             (define-type-alias B% (Class #:implements/inits A%
+                                          #:implements/inits A%))
+             (error "foo"))
+           ;; FIXME: this error message is pretty bad
+           #:msg "expected Class type clause"]
+   [tc-err (let ()
+             (define-type-alias A% (Class (init [y String])))
+             (define-type-alias B% (Class #:implements/inits A% (init [x String])))
+             (: b% B%)
+             (define b% (class object%
+                          (super-new)
+                          (init y x)))
+             (error "foo"))
+           #:msg "type mismatch"]))