Add support for local field access

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

@@ -293,10 +293,16 @@
     (define method-names
       (append (dict-ref name-dict #'public '())
               (dict-ref name-dict #'override '())))
+    (define field-names
+      (append (dict-ref name-dict #'field '())
+              (dict-ref name-dict #'init-field '())))
     (syntax-property
      #`(let-values ([(#,@method-names)
                      (values #,@(map (λ (stx) #`(λ () (#,stx)))
-                                     method-names))])
+                                     method-names))]
+                    [(#,@field-names)
+                     (values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0)))
+                                     field-names))])
          (void))
      'tr:class:local-table #t)))
 

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

@@ -139,49 +139,104 @@
      |#
      ;; trawl the body for the local name table
      (define locals (trawl-for-property #'body 'tr:class:local-table))
-     (define local-table
+     (define-values (local-method-table local-field-table)
-      (syntax-parse (car locals)
+       (construct-local-mapping-tables (car locals)))
-        #:literals (let-values #%plain-app #%plain-lambda)
-        [(let-values ([(method ...)
-                       (#%plain-app
-                        values
-                        (#%plain-lambda ()
-                          (#%plain-app (#%plain-app local-method self1) self2))
-                        ...)])
-            (#%plain-app void))
-          (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))
+     (define-values (lexical-names lexical-types)
-                                   (set->list this%-method-names))
+       (local-tables->lexical-env local-method-table methods this%-method-names
-                              ;; FIXME: the types we put here are fine in the expected
+                                  local-field-table fields this%-field-names
-                              ;;        case, but not if the class doesn't have an annotation.
+                                  self-type))
-                              ;;        Then we need to hunt down annotations in a first pass.
+     (with-lexical-env/extend lexical-names lexical-types
-                              ;;        (should probably do this in expected case anyway)
+      (check-methods meths methods self-type))
-                              ;; FIXME: this doesn't work because the names of local methods
-                              ;;        are obscured and need to be reconstructed somehow
-                              (map (λ (m) (->* (list (make-Univ))
-                                               (fixup-method-type (car (dict-ref methods m))
-                                                                  self-type)))
-                                   (set->list this%-method-names))
-      (for ([meth meths])
-        (define method-name (syntax-property meth 'tr:class:method))
-        (define method-type
-          (fixup-method-type
-           (car (dict-ref methods method-name))
-           self-type))
-        (define expected (ret method-type))
-        (define annotated (annotate-method meth self-type))
-        (tc-expr/check annotated expected)))
      ;; trawl the body for top-level expressions too
      (define top-level-exprs (trawl-for-property #'body 'tr:class:top-level))
      (void)]))
 
+;; local-tables->lexical-env : Dict<Symbol, Id> Dict List<Symbol>
+;;                             Dict<Symbol, (List Id Id)> Dict List<Symbol>
+;;                             Type
+;;                             -> List<Id> List<Type>
+;; Construct mappings to put into the lexical type-checking environment
+;; from the class local accessor mappings
+;;
+;; 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.
+;;        (should probably do this in expected case anyway)
+(define (local-tables->lexical-env local-method-table methods method-names
+                                   local-field-table fields field-names
+                                   self-type)
+  (define (localize local-table names)
+    (map (λ (m) (dict-ref local-table m))
+                (set->list names)))
+  (define localized-method-names (localize local-method-table method-names))
+  (define localized-field-pairs (localize local-field-table field-names))
+  (define localized-field-get-names (map car localized-field-pairs))
+  (define localized-field-set-names (map cadr localized-field-pairs))
+  (define method-types
+    (map (λ (m) (->* (list (make-Univ))
+                     (fixup-method-type (car (dict-ref methods m))
+                                        self-type)))
+         (set->list method-names)))
+  (define field-get-types
+    (map (λ (f) (->* (list (make-Univ)) (car (dict-ref fields f))))
+         (set->list field-names)))
+  (define field-set-types
+    (map (λ (f) (->* (list (make-Univ) (car (dict-ref fields f)))
+                     -Void))
+         (set->list field-names)))
+  (values (append localized-method-names
+                  localized-field-get-names localized-field-set-names)
+          (append method-types field-get-types field-set-types)))
+
+;; check-methods : Listof<Syntax> Dict Type -> Void
+;; Type-check the methods inside of a class
+(define (check-methods meths methods self-type)
+  (for ([meth meths])
+    (define method-name (syntax-property meth 'tr:class:method))
+    (define method-type
+      (fixup-method-type
+       (car (dict-ref methods method-name))
+       self-type))
+    (define expected (ret method-type))
+    (define annotated (annotate-method meth self-type method-type))
+    (tc-expr/check annotated expected)))
+
+;; Syntax -> Dict<Symbol, Id> Dict<Symbol, (List Symbol Symbol)>
+;; Construct tables mapping internal method names to the accessors
+;; generated inside the untyped class macro.
+(define (construct-local-mapping-tables stx)
+  (syntax-parse stx
+    #:literals (let-values #%plain-app #%plain-lambda values)
+    ;; See base-env/class-prims.rkt to see how this in-syntax
+    ;; table is constructed at the surface syntax
+    [(let-values ([(method:id ...)
+                   (#%plain-app
+                    values
+                    (#%plain-lambda ()
+                      (#%plain-app (#%plain-app local-method:id _) _))
+                    ...)]
+                  [(field:id ...)
+                   (#%plain-app
+                    values
+                    (#%plain-lambda ()
+                      (let-values (((_) _)) (#%plain-app local-field-get:id _))
+                      (let-values (((_) _))
+                        (let-values (((_) _)) (#%plain-app local-field-set:id _ _))))
+                    ...)])
+       (#%plain-app void))
+     (values (map cons
+                  (syntax->datum #'(method ...))
+                  (syntax->list #'(local-method ...)))
+             (map list
+                  (syntax->datum #'(field ...))
+                  (syntax->list #'(local-field-get ...))
+                  (syntax->list #'(local-field-set ...))))]))
+
 ;; 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)
@@ -244,8 +299,9 @@
     [_ (tc-error "fixup-method-type: internal error")]))
 
 ;; annotate-method : Syntax Type -> Syntax
-;; Adds a self type annotation for the first argument
+;; Adds a self type annotation for the first argument and annotated
-(define (annotate-method stx self-type)
+;; the let-values binding for tc-expr
+(define (annotate-method stx self-type method-type)
   (syntax-parse stx
     #:literals (let-values #%plain-lambda)
     [(let-values ([(meth-name:id)
@@ -254,7 +310,7 @@
        m)
      (define annotated-self-param
        (type-ascription-property #'self-param self-type))
-     #`(let-values ([(meth-name)
+     #`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type))
                      (#%plain-lambda (#,annotated-self-param id ...)
                        body ...)])
          m)]

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

@@ -285,5 +285,21 @@
    (check-err
     (: d% (Class [m (Integer -> Integer)]))
     (define d% (class: object% (super-new)
-                 (define/override (m y) (* 2 y)))))))
+                 (define/override (m y) (* 2 y)))))
+
+   ;; local field access and set!
+   (check-ok
+    (: c% (Class (field [x Integer])
+                 [m (Integer -> Integer)]))
+    (define c% (class: object% (super-new)
+                 (field [x 0])
+                 (define/public (m y)
+                   (begin0 x (set! x (+ x 1)))))))
+
+   ;; fails, missing local field
+   (check-err
+    (: c% (Class [m (Integer -> Integer)]))
+    (define c% (class: object% (super-new)
+                 (define/public (m y)
+                   (begin0 x (set! x (+ x 1)))))))))