Handle init/init-field order correctly in TR

Also handles the case where init and init-field clauses
are interleaved, in which case they need to be interleaved
in the type.

Closes PR 14408

original commit: a21a4a151ace08457a38d2af0664aecf44c30f0a

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt

@@ -341,12 +341,14 @@
         (define-values (annotated-methods other-top-level private-fields)
           (process-class-contents others name-dict))
         (define annotated-super (tr:class:super-property #'super #t))
+        (define ordered-inits (get-all-init-names clauses))
         (define optional-inits (get-optional-inits clauses))
         (ignore
          (tr:class
           #`(let-values ()
               #,(internal (make-class-name-table (attribute forall.type-variables)
                                                  private-fields
+                                                 ordered-inits
                                                  optional-inits
                                                  name-dict))
               (untyped-class #,annotated-super
@@ -450,6 +452,14 @@
                   #:when optional?)
          (stx-car id-pair)))))
 
+  ;; get-all-init-names : Listof<Clause> -> Listof<Id>
+  ;; Get a list of all the (internal) init names in order
+  (define (get-all-init-names clauses)
+    (flatten
+     (for/list ([clause clauses]
+                #:when (init-clause? clause))
+       (stx-map stx-car (clause-ids clause)))))
+
   ;; check-unsupported-features : Dict<Identifier, Names> -> Void
   ;; Check if features that are not supported were used and
   ;; raise an error if they are present
@@ -462,14 +472,19 @@
          "unsupported class clause: ~a"
          (syntax-e form)))))
 
-  ;; make-class-name-table : Listof<Id> Listof<Id> Listof<Id> Dict<Id, Id> -> Stx
+  ;; make-class-name-table : Listof<Id> Listof<Id> Listof<Id>
+  ;;                         Listof<Id> Dict<Id, Id> -> Stx
   ;; construct syntax used by the class type-checker as a reliable source
   ;; for the member names that are in a given class, plus any type
   ;; variables that are bound
-  (define (make-class-name-table foralls private-fields
-                                 optional-inits name-dict)
+  (define (make-class-name-table foralls
+                                 private-fields
+                                 ordered-inits
+                                 optional-inits
+                                 name-dict)
     #`(class-internal
        (#:forall #,@foralls)
+       (#:all-inits #,@ordered-inits)
        (init #,@(dict-ref name-dict #'init '()))
        (init-field #,@(dict-ref name-dict #'init-field '()))
        (init-rest #,@(dict-ref name-dict #'init-rest '()))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt

@@ -74,6 +74,7 @@
   (pattern (begin (quote-syntax
                    (class-internal
                     (#:forall type-parameter:id ...)
+                    (#:all-inits all-init-names:id ...)
                     (c:init init-names:name-pair ...)
                     (c:init-field init-field-names:name-pair ...)
                     (c:init-rest (~optional init-rest-name:id))
@@ -89,6 +90,7 @@
                     (c:pubment pubment-names:name-pair ...)))
                   (#%plain-app values))
            #:with type-parameters #'(type-parameter ...)
+           #:with all-init-internals #'(all-init-names ...)
            #:with init-internals #'(init-names.internal ...)
            #:with init-externals #'(init-names.external ...)
            #:with init-field-internals #'(init-field-names.internal ...)
@@ -160,6 +162,7 @@
   #:literals (let-values letrec-syntaxes+values #%plain-app)
   #:attributes (superclass-expr
                 type-parameters
+                all-init-internals
                 init-internals init-externals
                 init-field-internals init-field-externals
                 init-rest-name
@@ -252,9 +255,9 @@
              'optional-inits      (syntax->datum #'cls.optional-inits)
              'only-init-internals (syntax->datum #'cls.init-internals)
              'only-init-names     (syntax->datum #'cls.init-externals)
-             'init-internals
-             (set-union (syntax->datum #'cls.init-internals)
-                        (syntax->datum #'cls.init-field-internals))
+             ;; the order of these names reflect the order in the class,
+             ;; so use this list when retaining the order is important
+             'init-internals      (syntax->datum #'cls.all-init-internals)
              'init-rest-name     (and (attribute cls.init-rest-name)
                                       (syntax-e (attribute cls.init-rest-name)))
              'public-internals   (syntax->datum #'cls.public-internals)

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

@@ -1251,6 +1251,25 @@
                           (init-rest [rst : (List Symbol)])))
              (make-object c% "wrong"))
            #:msg #rx"expected: Symbol.*given: String"]
+   ;; PR 14408, test init-field order
+   [tc-e (let ()
+           (define c%
+             (class object%
+               (super-new)
+               (init-field [x : String] [y : Symbol])))
+           (make-object c% "str" 'sym)
+           (void))
+         -Void]
+   ;; a variant of the last, but testing that init and init-field
+   ;; interleave correctly in the class type
+   [tc-e (let ()
+           (define c%
+             (class object%
+               (super-new)
+               (init [a : 'a]) (init-field [x : 'x] [y : 'y]) (init [b 'b])))
+           (make-object c% 'a 'x 'y 'b)
+           (void))
+         -Void]
    ;; fail, too many positional arguments to superclass
    [tc-err (class object% (super-make-object "foo"))
            #:msg #rx"too many positional init arguments"]