Check super-new calls

Still need to use this information to adjust the class
type init clauses

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

@@ -225,24 +225,7 @@
                            non-clause?))
         (define name-dict (extract-names clauses))
         (define-values (annotated-methods other-top-level)
-          (for/fold ([methods '()]
-                     [rest-top '()])
-                    ([other others])
-            (define stx (non-clause-stx other))
-            (syntax-parse stx
-              ;; if it's a method definition for a declared method, then
-              ;; mark it as something to type-check
-              [(define-values (id) . rst)
-               #:when (memf (λ (n) (free-identifier=? #'id n))
-                            (dict-ref name-dict #'public))
-               (values (cons (non-clause (syntax-property stx
-                                                          'tr:class:method
-                                                          (syntax-e #'id)))
-                             methods)
-                       rest-top)]
-              ;; FIXME: this needs to handle external/internal names too
-              ;; FIXME: this needs to track overrides and other things
-              [_ (values methods (append rest-top (list other)))])))
+          (process-class-contents others name-dict))
         (define annotated-super
           (syntax-property #'super 'tr:class:super #t))
         (syntax-property
@@ -267,6 +250,35 @@
          'typechecker:ignore #t)])]))
 
 (begin-for-syntax
+  ;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>>
+  ;;                          -> Listof<Syntax> Listof<Syntax>
+  ;; Process methods and other top-level expressions and definitions
+  ;; that aren't class clauses like `init` or `public`
+  (define (process-class-contents contents name-dict)
+    (for/fold ([methods '()]
+               [rest-top '()])
+              ([content contents])
+      (define stx (non-clause-stx content))
+      (syntax-parse stx
+        #:literals (define-values super-new)
+        ;; if it's a method definition for a declared method, then
+        ;; mark it as something to type-check
+        ;; FIXME: this needs to handle external/internal names too
+        ;; FIXME: this needs to track overrides and other things
+        [(define-values (id) . rst)
+         #:when (memf (λ (n) (free-identifier=? #'id n))
+                      (dict-ref name-dict #'public))
+         (values (cons (non-clause (syntax-property stx
+                                                    'tr:class:method
+                                                    (syntax-e #'id)))
+                       methods)
+                 rest-top)]
+        ;; Identify super-new for the benefit of the type checker
+        [(super-new [init-id init-expr] ...)
+         (define new-non-clause
+           (non-clause (syntax-property stx 'tr:class:super-new #t)))
+         (values methods (append rest-top (list new-non-clause)))]
+        [_ (values methods (append rest-top (list content)))])))
   ;; This is a neat/horrible trick
   ;;
   ;; In order to detect the mappings that class-internal.rkt has

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

@@ -145,6 +145,9 @@
           (map cons
               (syntax->datum #'(method ...))
               (syntax->list #'(local-method ...)))]))
+     ;; find the `super-new` call (or error if missing)
+     (define super-new-stx (trawl-for-property #'body 'tr:class:super-new))
+     (check-super-new super-new-stx super-inits)
      ;; trawl the body and find methods and type-check them
      (define meths (trawl-for-property #'body 'tr:class:method))
      (with-lexical-env/extend (map (λ (m) (dict-ref local-table m))
@@ -172,6 +175,28 @@
      (define top-level-exprs (trawl-for-property #'body 'tr:class:top-level))
      (void)]))
 
+;; check-super-new : Listof<Syntax> Inits -> Void
+;; Check if the super-new call is well-typed
+(define (check-super-new super-new-stx super-inits)
+  (cond [(null? super-new-stx)
+         (tc-error/expr
+          "typed classes must call super-new at the class top-level")]
+        [else
+         (syntax-parse (car super-new-stx)
+           #:literals (#%plain-app list cons quote)
+           [(#%plain-app super-go _ _ _ _ _
+                         (#%plain-app
+                          list
+                          (#%plain-app cons (quote init-id) arg:expr)
+                          ...))
+            (for ([init-id (syntax->datum #'(init-id ...))]
+                  [init-arg (syntax->list #'(arg ...))])
+              (define maybe-expected (dict-ref super-inits init-id #f))
+              (if maybe-expected
+                  (tc-expr/check init-arg (ret (car maybe-expected)))
+                  (tc-error/expr "init argument ~a not accepted by superclass"
+                                 init-id)))])]))
+
 ;; Syntax -> Listof<Syntax>
 ;; Look through the expansion of the class macro in search for
 ;; syntax with some property (e.g., methods)

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

@@ -235,5 +235,29 @@
               (public m)
               (define-values (m)
                 (lambda (x) (number->string x))))])
-      (send (new c%) m 4)))))
+      (send (new c%) m 4)))
+
+   ;; check a good super-new call
+   (check-ok
+    (: c% (Class (init [x Integer])))
+    (define c% (class: object% (super-new) (init x)))
+    (: d% (Class))
+    (define d% (class: c% (super-new [x (+ 3 5)]))))
+
+   ;; fails, missing super-new
+   (check-err
+    (: c% (Class (init [x Integer])))
+    (define c% (class: object% (init x))))
+
+   ;; fails, non-top-level super-new
+   (check-err
+    (: c% (Class (init [x Integer])))
+    (define c% (class: object% (let () (super-new)) (init x))))
+
+   ;; fails, bad super-new argument
+   (check-err
+    (: c% (Class (init [x Integer])))
+    (define c% (class: object% (super-new) (init x)))
+    (: d% (Class))
+    (define d% (class: c% (super-new [x "bad"]))))))