Add support for override

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

@@ -238,7 +238,8 @@
                     (init #,@(dict-ref name-dict #'init '()))
                     (init-field #,@(dict-ref name-dict #'init-field '()))
                     (field #,@(dict-ref name-dict #'field '()))
-                    (public #,@(dict-ref name-dict #'public '()))))
+                    (public #,@(dict-ref name-dict #'public '()))
+                    (override #,@(dict-ref name-dict #'override '()))))
               (class #,annotated-super
                 #,@(map clause-stx clauses)
                 #,@(map non-clause-stx annotated-methods)
@@ -264,10 +265,11 @@
         ;; 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
+        ;; FIXME: this needs to track privates, augments, etc.
         [(define-values (id) . rst)
          #:when (memf (λ (n) (free-identifier=? #'id n))
-                      (dict-ref name-dict #'public))
+                      (append (dict-ref name-dict #'public '())
+                              (dict-ref name-dict #'override '())))
          (values (cons (non-clause (syntax-property stx
                                                     'tr:class:method
                                                     (syntax-e #'id)))
@@ -288,10 +290,13 @@
   ;; set!-transformers to the appropriate accessors, which lets
   ;; us figure out the accessor identifiers.
   (define (make-locals-table name-dict)
-   (syntax-property
+    (define method-names
-    #`(let-values ([(#,@(dict-ref name-dict #'public '()))
+      (append (dict-ref name-dict #'public '())
-                    (values #,@(map (λ (stx) #`(λ () (#,stx)))
+              (dict-ref name-dict #'override '())))
-                                    (dict-ref name-dict #'public '())))])
+    (syntax-property
-        (void))
+     #`(let-values ([(#,@method-names)
-    'tr:class:local-table #t)))
+                     (values #,@(map (λ (stx) #`(λ () (#,stx)))
+                                     method-names))])
+         (void))
+     'tr:class:local-table #t)))
 

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

@@ -48,7 +48,7 @@
   (syntax-parse form
     #:literals (let-values #%plain-lambda quote-syntax begin
                 #%plain-app values class:-internal letrec-syntaxes+values
-                c:init c:init-field c:field c:public)
+                c:init c:init-field c:field c:public c:override)
     ;; Inspect the expansion of the class macro for the pieces that
     ;; we need to type-check like superclass, methods, top-level
     ;; expressions and so on
@@ -63,7 +63,8 @@
                                      (c:init internal-init-names ...)
                                      (c:init-field internal-init-field-names ...)
                                      (c:field internal-field-names ...)
-                                     (c:public internal-public-names ...)))
+                                     (c:public internal-public-names ...)
+                                     (c:override internal-override-names ...)))
                                    (#%plain-app values))))
                                (let-values (((superclass) superclass-expr)
                                             ((interfaces) interface-expr))
@@ -103,8 +104,12 @@
        (list->set
         (append (syntax->datum #'(internal-field-names ...))
                 (syntax->datum #'(internal-init-field-names ...)))))
-     (define this%-method-names
+     (define this%-public-names
        (list->set (syntax->datum #'(internal-public-names ...))))
+     (define this%-override-names
+       (list->set (syntax->datum #'(internal-override-names ...))))
+     (define this%-method-names
+       (set-union this%-public-names this%-override-names))
      ;; Use the internal class: information to check whether clauses
      ;; exist or are absent appropriately
      (when expected?
@@ -114,20 +119,22 @@
       (check-exists (set-union this%-init-names super-init-names)
                     exp-init-names
                     "initialization argument")
-      (check-exists (set-union this%-method-names super-method-names)
+      (check-exists (set-union this%-public-names super-method-names)
                     exp-method-names
                     "public method")
       (check-exists (set-union this%-field-names super-field-names)
                     exp-field-names
                     "public field"))
+     (check-exists super-method-names this%-override-names
+                   "override method")
      (check-absent super-field-names this%-field-names "public field")
-     (check-absent super-method-names this%-method-names "public method")
+     (check-absent super-method-names this%-public-names "public method")
      ;; FIXME: the control flow for the failure of these checks is
      ;;        still up in the air
      #|
      (check-no-extra (set-union this%-field-names super-field-names)
                      exp-field-names)
-     (check-no-extra (set-union this%-method-names super-method-names)
+     (check-no-extra (set-union this%-public-names super-method-names)
                      exp-method-names)
      |#
      ;; trawl the body for the local name table
@@ -151,7 +158,7 @@
      ;; 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))
-                                   (syntax->datum #'(internal-public-names ...)))
+                                   (set->list this%-method-names))
                               ;; FIXME: the types we put here are fine in the expected
                               ;;        case, but not if the class doesn't have an annotation.
                               ;;        Then we need to hunt down annotations in a first pass.
@@ -161,7 +168,7 @@
                               (map (λ (m) (->* (list (make-Univ))
                                                (fixup-method-type (car (dict-ref methods m))
                                                                   self-type)))
-                                   (syntax->datum #'(internal-public-names ...)))
+                                   (set->list this%-method-names))
       (for ([meth meths])
         (define method-name (syntax-property meth 'tr:class:method))
         (define method-type

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

@@ -259,5 +259,31 @@
     (: c% (Class (init [x Integer])))
     (define c% (class: object% (super-new) (init x)))
     (: d% (Class))
-    (define d% (class: c% (super-new [x "bad"]))))))
+    (define d% (class: c% (super-new [x "bad"]))))
+
+   ;; test override
+   (check-ok
+    (: c% (Class [m (Integer -> Integer)]))
+    (define c% (class: object% (super-new)
+                 (define/public (m y) (add1 y))))
+    (: d% (Class [m (Integer -> Integer)]))
+    (define d% (class: c% (super-new)
+                 (define/override (m y) (* 2 y)))))
+
+   ;; test local call to overriden method
+   (check-ok
+    (: c% (Class [m (Integer -> Integer)]))
+    (define c% (class: object% (super-new)
+                 (define/public (m y) (add1 y))))
+    (: d% (Class [n (Integer -> Integer)]
+                 [m (Integer -> Integer)]))
+    (define d% (class: c% (super-new)
+                 (define/public (n x) (m x))
+                 (define/override (m y) (* 2 y)))))
+
+   ;; fails, superclass missing public for override
+   (check-err
+    (: d% (Class [m (Integer -> Integer)]))
+    (define d% (class: object% (super-new)
+                 (define/override (m y) (* 2 y)))))))