Remove the depth subtype check on #:implements

This check was not really necessary to begin with,
but I thought it might be a useful sanity check. In
retrospect, calling `subtype` here causes other headaches
(such as when registering type aliases) and is confusing
when multiple #:implements are provided.

Instead, the #:implements clauses are just linearized
and the last type for any given method/field is taken.

This may also prevent a heisenbug that occurs in the
GUI framework types. I still don't know the root cause of
that non-determinism though.

Closes PR 14669

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

@@ -312,7 +312,9 @@ additional provides all other bindings from @racketmodname[racket/class].
   and @racket[init-field] clauses.
 
   Multiple @racket[#:implements] clauses may be provided for a single class
-  type.
+  type. The types for the @racket[#:implements] clauses are merged in order and the
+  last type for a given method name or field is used (the types in the @racket[Class]
+  type itself takes precedence).
 
   @ex[
     (define-type Point<%> (Class (field [x Real] [y Real])))

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

@@ -628,27 +628,14 @@
 ;;                         -> Option<Id> FieldDict MethodDict AugmentDict
 ;; Merges #:implements class type and the current class clauses appropriately
 (define (merge-with-parent-type row-var parent-type parent-stx fields methods augments)
-  ;; (Listof Symbol) Dict Dict String -> (Values Dict Dict)
+  ;; merge-clause : Dict Dict -> Dict
-  ;; check for duplicates in a class clause
+  ;; Merge all the non-duplicate entries from the parent types
-  (define (check-duplicate-clause names super-names types super-types err-msg)
+  (define (merge-clause parent-clause clause)
-    (define maybe-dup (check-duplicate (append names super-names)))
+    (for/fold ([clause clause])
-    (cond [maybe-dup
+              ([(k v) (in-dict parent-clause)])
-           (define type (car (dict-ref types maybe-dup)))
+      (if (dict-has-key? clause k)
-           (define super-type (car (dict-ref super-types maybe-dup)))
+          clause
-           (cond [;; if there is a duplicate, but the type is a subtype,
+          (dict-set clause k v))))
-                  ;; then let it through and check for any other duplicates
-                  (unless (subtype type super-type)
-                    (parse-error "class member type not a subtype of parent member type"
-                                 "member" maybe-dup
-                                 "type" type
-                                 "parent type" super-type))
-                  (check-duplicate-clause
-                   names (remove maybe-dup super-names)
-                   types (dict-remove super-types maybe-dup)
-                   err-msg)]
-                 [else
-                  (parse-error #:stx parent-stx err-msg "name" maybe-dup)])]
-          [else (values types super-types)]))
 
   (define (match-parent-type parent-type)
     (define resolved (resolve parent-type))
@@ -668,24 +655,6 @@
   (match-define (list (list super-method-names _) ...) super-methods)
   (match-define (list (list super-augment-names _) ...) super-augments)
 
-  ;; if any duplicates are found between this class and the superclass
-  ;; type, then raise an error
-  (define-values (checked-fields checked-super-fields)
-    (check-duplicate-clause
-     field-names super-field-names
-     fields super-fields
-     "field or init-field name conflicts with #:implements clause"))
-  (define-values (checked-methods checked-super-methods)
-    (check-duplicate-clause
-     method-names super-method-names
-     methods super-methods
-     "method name conflicts with #:implements clause"))
-  (define-values (checked-augments checked-super-augments)
-    (check-duplicate-clause
-     augment-names super-augment-names
-     augments super-augments
-     "augmentable method name conflicts with #:implements clause"))
-
   ;; it is an error for both the extending type and extended type
   ;; to have row variables
   (when (and row-var super-row-var)
@@ -693,9 +662,9 @@
                      " extend another type that has a row variable")))
 
   ;; then append the super types if there were no errors
-  (define merged-fields (append checked-super-fields checked-fields))
+  (define merged-fields (merge-clause super-fields fields))
-  (define merged-methods (append checked-super-methods checked-methods))
+  (define merged-methods (merge-clause super-methods methods))
-  (define merged-augments (append checked-super-augments checked-augments))
+  (define merged-augments (merge-clause super-augments augments))
 
   ;; make sure augments and methods are disjoint
   (define maybe-dup-method (check-duplicate (dict-keys merged-methods)))
@@ -773,9 +742,9 @@
                          [fields given-fields]
                          [methods given-methods]
                          [augments given-augments])
-                  ([parent-type parent-types]
+                  ([parent-type (reverse parent-types)]
-                   [parent-stx  (append (or (list parent/init-stx) null)
+                   [parent-stx  (reverse (append (or (list parent/init-stx) null)
-                                        parent-stxs)])
+                                                 parent-stxs))])
                 (merge-with-parent-type row-var parent-type parent-stx
                                         fields methods augments)))
 

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

@@ -1632,4 +1632,23 @@
                           (super-new)
                           (init y x)))
              (error "foo"))
-           #:msg "type mismatch"]))
+           #:msg "type mismatch"]
+   ;; PR 14669 (next two)
+   [tc-e (let ()
+           (define-type-alias A (Class [m (-> Any)]))
+           (define-type-alias B (Class #:implements A [m (-> Void)]))
+           (define-type-alias C (Class #:implements A))
+           (define-type-alias D (Class #:implements C #:implements B))
+           (: d% D)
+           (define d% (class object% (super-new) (define/public (m) (void))))
+           (send (new d%) m))
+         -Void]
+   [tc-e (let ()
+           (define-type-alias A (Class [m (-> Any)]))
+           (define-type-alias B (Class #:implements A [m (-> Void)]))
+           (define-type-alias C (Class #:implements A))
+           (define-type-alias D (Class #:implements B #:implements C))
+           (: d% D)
+           (define d% (class object% (super-new) (define/public (m) (void))))
+           (send (new d%) m))
+         Univ]))