Revise TR classes & docs based on feedback

original commit: 1c6c0855f788fb311db7a93b5e81bbcd6b24d03b
2014-01-29 16:18:33 -05:00 · 2014-01-29 16:18:33 -05:00 · ffdb6752f3
commit ffdb6752f3
parent 6cd8927abc
7 changed files with 160 additions and 122 deletions
--- a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl
+++ b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl
@ -28,11 +28,11 @@ For a friendly introduction, see the companion manual
@include-section["reference/types.scrbl"]
@include-section["reference/special-forms.scrbl"]
@include-section["reference/libraries.scrbl"]
+@include-section["reference/typed-classes.scrbl"]
@include-section["reference/utilities.scrbl"]
@include-section["reference/exploring-types.scrbl"]
@include-section["reference/no-check.scrbl"]
@include-section["reference/typed-regions.scrbl"]
-@include-section["reference/typed-classes.scrbl"]
@include-section["reference/optimization.scrbl"]
@include-section["reference/legacy.scrbl"]
@include-section["reference/compatibility-languages.scrbl"]
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
@ -22,7 +22,6 @@
 (only-in (types numeric-tower) [-Number N])
 (only-in (rep type-rep)
          make-ClassTop
-          make-Instance
          make-Name
          make-ValuesDots
          make-MPairTop
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
@ -4,22 +4,26 @@

 (require (rename-in racket/class [class untyped-class])
         "colon.rkt"
+         "../typecheck/internal-forms.rkt"
         (for-syntax
          racket/base
          racket/class
          racket/dict
          racket/list
          racket/match
-          racket/pretty ;; get rid of this later
          racket/syntax
-          racket/private/classidmap ;; this is bad
+          ;; Note: This imports `generate-class-expand-context` from
+          ;;       the internals of the class system. It's needed for
+          ;;       local expansion to establish the right context, but it
+          ;;       is hacky.
+          racket/private/classidmap
          syntax/flatten-begin
          syntax/id-table
          syntax/kerncase
          syntax/parse
          syntax/stx
          unstable/list
-          (for-template "../typecheck/internal-forms.rkt")
+          "../private/syntax-properties.rkt"
          "../utils/tc-utils.rkt"
          "../types/utils.rkt"))

@ -95,12 +99,13 @@
                       extract-names clause init-clause get-optional-inits)))

 (begin-for-syntax
- ;; A Clause is a (clause Syntax Id Listof<Syntax> Option<Type>)
+ ;; A Clause is a (clause Syntax Id Listof<Syntax> Listof<Option<Type>>)
 ;;
 ;; interp. a class clause such as init or field.
+ ;;   stx   - the syntax of the entire clause with types erased
 ;;   kind  - the kind of clause (e.g., init, field)
 ;;   ids   - list of the ids defined in this clause
- ;;   types - types for each id, #f if none provided
+ ;;   types - types for each id, #f if a type is not provided
 (struct clause (stx kind ids types))

 ;; An InitClause is a (init-clause Syntax Id Listof<Syntax> Boolean)
@ -114,6 +119,9 @@
 ;;         class clauses such as init or field.
 (struct non-clause (stx))

+ (define-literal-set class-literals
+   (:))
+
 (define-splicing-syntax-class maybe-type-parameter
   (pattern (~seq #:forall type-variable:id)
            #:attr type-variables #'(type-variable))
@ -121,24 +129,30 @@
            #:attr type-variables #'(type-variable ...))
   (pattern (~seq)
            #:attr type-variables #'()))
- 
+
+ ;; interp:
+ ;;   optional? - optional init arg or not (has default value or not)
+ ;;   ids       - internal and external id for this argument
+ ;;   type      - type annotation, if any
+ ;;   form      - type erased form
 (define-syntax-class init-decl
   #:attributes (optional? ids type form)
+   #:literal-sets (class-literals)
   (pattern id:id
            #:attr optional? #f
            #:with ids #'(id id)
            #:attr type #f
            #:with form this-syntax)
-   (pattern (id:id (~datum :) type:expr)
+   (pattern (id:id : type:expr)
            #:attr optional? #f
            #:with ids #'(id id)
            #:with form #'id)
-   (pattern (ren:renamed (~optional (~seq (~datum :) type:expr)))
+   (pattern (ren:renamed (~optional (~seq : type:expr)))
            #:attr optional? #f
            #:with ids #'ren.ids
            #:with form #'(ren))
   (pattern (mren:maybe-renamed
-             (~optional (~seq (~datum :) type:expr))
+             (~optional (~seq : type:expr))
             default-value:expr)
            #:attr optional? #t
            #:with ids #'mren.ids
@ -146,45 +160,74 @@

 (define-syntax-class field-decl
   #:attributes (ids type form)
+   #:literal-sets (class-literals)
   (pattern (mren:maybe-renamed
-             (~optional (~seq (~datum :) type:expr))
+             (~optional (~seq : type:expr))
             default-value:expr)
            #:with ids #'mren.ids
            #:with form #'(mren default-value)))

 (define-syntax-class method-decl
   #:attributes (ids type form)
+   #:literal-sets (class-literals)
   (pattern mren:maybe-renamed
            #:with ids #'mren.ids
            #:attr type #f
            #:with form this-syntax)
-   (pattern (mren:maybe-renamed (~datum :) type:expr)
+   (pattern (mren:maybe-renamed : type:expr)
            #:with ids #'mren.ids
            #:with form #'mren))

 (define-syntax-class private-decl
   #:attributes (id type form)
+   #:literal-sets (class-literals)
   (pattern id:id
            #:attr type #f
            #:with form this-syntax)
-   (pattern (id:id (~datum :) type:expr)
+   (pattern (id:id : type:expr)
            #:with form #'id))

 (define-syntax-class renamed
+   #:attributes (ids)
   (pattern (internal-id:id external-id:id)
            #:with ids #'(internal-id external-id)))

 (define-syntax-class maybe-renamed
+   #:attributes (ids)
   (pattern id:id
            #:with ids #'(id id))
   (pattern ren:renamed
            #:with ids #'ren.ids))

+ (define-syntax-class init-like-clause-names
+   (pattern (~or (~literal init)
+                 (~literal init-field))))
+
+ ;; matches ids with clauses shaped like method clauses,
+ ;; not necessarily clauses that declare methods
+ (define-syntax-class method-like-clause-names
+   (pattern (~or (~literal inherit-field)
+                 (~literal public)
+                 (~literal pubment)
+                 (~literal public-final)
+                 (~literal override)
+                 (~literal overment)
+                 (~literal override-final)
+                 (~literal augment)
+                 (~literal augride)
+                 (~literal augment-final)
+                 (~literal inherit)
+                 (~literal inherit/super)
+                 (~literal inherit/inner)
+                 (~literal rename-super))))
+
+ (define-syntax-class private-like-clause-names
+   (pattern (~or (~literal private)
+                 (~literal abstract))))
+
 (define-syntax-class class-clause
-   (pattern ((~and clause-name (~or (~literal init)
-                                    (~literal init-field)))
-             names:init-decl ...)
-            ;; in the future, use a data structure and
+   (pattern (clause-name:init-like-clause-names names:init-decl ...)
+            ;; FIXME: in the future, use a data structure and
            ;; make this an attribute instead to represent
            ;; internal and external names
            #:attr data
@ -203,29 +246,13 @@
                                #'field
                                (stx->list #'(names.ids ...))
                                (attribute names.type)))
-   (pattern ((~and clause-name (~or (~literal inherit-field)
-                                    (~literal public)
-                                    (~literal pubment)
-                                    (~literal public-final)
-                                    (~literal override)
-                                    (~literal overment)
-                                    (~literal override-final)
-                                    (~literal augment)
-                                    (~literal augride)
-                                    (~literal augment-final)
-                                    (~literal inherit)
-                                    (~literal inherit/super)
-                                    (~literal inherit/inner)
-                                    (~literal rename-super)))
-             names:method-decl ...)
+   (pattern (clause-name:method-like-clause-names names:method-decl ...)
            #:attr data
            (clause #'(clause-name names.form ...)
                    #'clause-name
                    (stx->list #'(names.ids ...))
                    (attribute names.type)))
-   (pattern ((~and clause-name (~or (~literal private)
-                                    (~literal abstract)))
-             names:private-decl ...)
+   (pattern (clause-name:private-like-clause-names names:private-decl ...)
            #:attr data
            (clause #'(clause-name names.form ...)
                    #'clause-name
@ -233,21 +260,19 @@
                    (attribute names.type))))

 (define-syntax-class class-clause-or-other
-   (pattern e:class-clause #:attr data (attribute e.data))
+   #:attributes (data)
+   (pattern :class-clause)
   (pattern e:expr #:attr data (non-clause #'e)))

 ;; Listof<Clause> -> Dict<Identifier, Names>
 ;; Extract names from init, public, etc. clauses
 (define (extract-names clauses)
   (for/fold ([clauses (make-immutable-free-id-table)])
-             ([clause clauses])
-     (if (dict-has-key? clauses (clause-kind clause))
-         (dict-update clauses (clause-kind clause)
-                      (λ (old-names)
-                        (append old-names (clause-ids clause))))
-         (dict-set clauses
-                   (clause-kind clause)
-                   (clause-ids clause)))))
+             ([clause (in-list clauses)])
+     (dict-update clauses (clause-kind clause)
+                  (λ (old-names)
+                    (append old-names (clause-ids clause)))
+                  '())))

 ;; FIXME: less magic
 ;; magic used to disarm syntax after expansion
@ -267,7 +292,7 @@
           [else
            (define stx (disarm (class-expand (car stxs))))
            (syntax-parse stx
-              #:literals (begin define-syntaxes)
+              #:literals (begin define-syntaxes define-values)
              [(begin . _)
               (loop (append (flatten-begin stx) (cdr stxs)))]
              ;; Handle syntax definitions in the expanded syntax
@ -301,7 +326,6 @@
 (define-syntax (class stx)
  (syntax-parse stx
    [(_ super forall:maybe-type-parameter e ...)
-     ;; FIXME: potentially needs to expand super clause?
     (define class-ctx (generate-class-expand-context))
     (define def-ctx (syntax-local-make-definition-context))
     (define expanded-stx
@ -318,30 +342,15 @@
        (internal-definition-context-seal def-ctx)
        (define-values (annotated-methods other-top-level private-fields)
          (process-class-contents others name-dict))
-        (define annotated-super
-          (syntax-property #'super 'tr:class:super #t))
+        (define annotated-super (tr:class:super-property #'super #t))
        (define optional-inits (get-optional-inits clauses))
-        (syntax-property
-         (syntax-property
+        (ignore
+         (tr:class
          #`(let-values ()
-              #,(internal
-                 ;; FIXME: maybe put this in a macro and/or a syntax class
-                 ;;        so that it's easier to deal with
-                 #`(class-internal
-                    (#:forall #,@(attribute forall.type-variables))
-                    (init #,@(dict-ref name-dict #'init '()))
-                    (init-field #,@(dict-ref name-dict #'init-field '()))
-                    (init-rest #,@(dict-ref name-dict #'init-rest '()))
-                    (optional-init #,@optional-inits)
-                    (field #,@(dict-ref name-dict #'field '()))
-                    (public #,@(dict-ref name-dict #'public '()))
-                    (override #,@(dict-ref name-dict #'override '()))
-                    (private #,@(dict-ref name-dict #'private '()))
-                    (private-field #,@private-fields)
-                    (inherit #,@(dict-ref name-dict #'inherit '()))
-                    (inherit-field #,@(dict-ref name-dict #'inherit-field '()))
-                    (augment #,@(dict-ref name-dict #'augment '()))
-                    (pubment #,@(dict-ref name-dict #'pubment '()))))
+              #,(internal (make-class-name-table (attribute forall.type-variables)
+                                                 private-fields
+                                                 optional-inits
+                                                 name-dict))
              (untyped-class #,annotated-super
                #,@(map clause-stx clauses)
                ;; construct in-body type annotations for clauses
@ -350,19 +359,20 @@
                            (match-define (clause _1 _2 ids types) a-clause)
                            (for/list ([id ids] [type types]
                                       #:when type)
-                              (syntax-property
-                               (syntax-property
+                              ;; FIXME: it might be cleaner to use the type-label-property
+                              ;;        here and use the property to build annotation tables
+                              ;;        in the class type-checker.
+                              (tr:class:type-annotation-property
+                               (tr:class:top-level-property
                                #`(: #,(if (stx-pair? id) (stx-car id) id)
                                     #,type)
-                                'tr:class:top-level #t)
-                               'tr:class:type-annotation #t))))
+                                #t)
+                               #t))))
                #,@(map non-clause-stx annotated-methods)
-                #,(syntax-property
+                #,(tr:class:top-level-property
                   #`(begin #,@(map non-clause-stx other-top-level))
-                   'tr:class:top-level #t)
-                #,(make-locals-table name-dict private-fields)))
-          'tr:class #t)
-         'typechecker:ignore #t)])]))
+                   #t)
+                #,(make-locals-table name-dict private-fields)))))])]))

 (begin-for-syntax
  ;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>>
@ -381,15 +391,8 @@
        ;; 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))
-                      (append (stx-map stx-car (dict-ref name-dict #'public '()))
-                              (stx-map stx-car (dict-ref name-dict #'pubment '()))
-                              (stx-map stx-car (dict-ref name-dict #'override '()))
-                              (stx-map stx-car (dict-ref name-dict #'augment '()))
-                              (dict-ref name-dict #'private '())))
-         (values (cons (non-clause (syntax-property stx
-                                                    'tr:class:method
-                                                    (syntax-e #'id)))
+         #:when (method-id? #'id name-dict)
+         (values (cons (non-clause (tr:class:method-property stx (syntax-e #'id)))
                       methods)
                 rest-top private-fields)]
        ;; private field definition
@ -401,19 +404,19 @@
        ;; special : annotation for augment interface
        [(: name:id type:expr #:augment augment-type:expr)
         (define new-clause
-           (non-clause (syntax-property #'(quote-syntax (:-augment name augment-type))
-                                        'tr:class:type-annotation #t)))
+           (non-clause (tr:class:type-annotation-property
+                        #'(quote-syntax (:-augment name augment-type)) #t)))
         (define plain-annotation
-           (non-clause (syntax-property (syntax/loc stx (: name type))
-                                        'tr:class:type-annotation #t)))
+           (non-clause (tr:class:type-annotation-property
+                        (syntax/loc stx (: name type)) #t)))
         (values methods
                 (append rest-top (list plain-annotation new-clause))
                 private-fields)]
        ;; Just process this to add the property
        [(: name:id type:expr)
         (define plain-annotation
-           (non-clause (syntax-property (syntax/loc stx (: name type))
-                                        'tr:class:type-annotation #t)))
+           (non-clause (tr:class:type-annotation-property
+                        (syntax/loc stx (: name type)) #t)))
         (values methods
                 (append rest-top (list plain-annotation))
                 private-fields)]
@ -422,14 +425,24 @@
              (super-make-object init-expr ...)
              (super-instantiate (init-expr ...) [name expr] ...))
         (define new-non-clause
-           (non-clause (syntax-property stx 'tr:class:super-new #t)))
+           (non-clause (tr:class:super-new-property stx #t)))
         (values methods (append rest-top (list new-non-clause))
                 private-fields)]
        [_ (values methods (append rest-top (list content))
                   private-fields)])))

+  ;; method-id? : Id Dict<Id, Id> -> Boolean
+  ;; Check whether the given id is a known method name
+  (define (method-id? id name-dict)
+    (memf (λ (n) (free-identifier=? id n))
+          (append (stx-map stx-car (dict-ref name-dict #'public '()))
+                  (stx-map stx-car (dict-ref name-dict #'pubment '()))
+                  (stx-map stx-car (dict-ref name-dict #'override '()))
+                  (stx-map stx-car (dict-ref name-dict #'augment '()))
+                  (dict-ref name-dict #'private '()))))
+
  ;; get-optional-inits : Listof<Clause> -> Listof<Id>
-  ;; Get a list of the internal names of mandatory inits
+  ;; Get a list of the internal names of optional inits
  (define (get-optional-inits clauses)
    (flatten
     (for/list ([clause clauses]
@ -451,6 +464,28 @@
         "unsupported class clause: ~a"
         (syntax-e form)))))

+  ;; make-class-name-table : 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)
+    #`(class-internal
+       (#:forall #,@foralls)
+       (init #,@(dict-ref name-dict #'init '()))
+       (init-field #,@(dict-ref name-dict #'init-field '()))
+       (init-rest #,@(dict-ref name-dict #'init-rest '()))
+       (optional-init #,@optional-inits)
+       (field #,@(dict-ref name-dict #'field '()))
+       (public #,@(dict-ref name-dict #'public '()))
+       (override #,@(dict-ref name-dict #'override '()))
+       (private #,@(dict-ref name-dict #'private '()))
+       (private-field #,@private-fields)
+       (inherit #,@(dict-ref name-dict #'inherit '()))
+       (inherit-field #,@(dict-ref name-dict #'inherit-field '()))
+       (augment #,@(dict-ref name-dict #'augment '()))
+       (pubment #,@(dict-ref name-dict #'pubment '()))))
+
  ;; This is a neat/horrible trick
  ;;
  ;; In order to detect the mappings that class-internal.rkt has
@ -478,7 +513,7 @@
    (define augment-names
      (append (stx-map stx-car (dict-ref name-dict #'pubment '()))
              (stx-map stx-car (dict-ref name-dict #'augment '()))))
-    (syntax-property
+    (tr:class:local-table-property
     #`(let-values ([(#,@public-names)
                     (values #,@(map (λ (stx) #`(λ () (#,stx)))
                                     public-names))]
@ -510,5 +545,5 @@
                     (values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx)))
                                     augment-names))])
         (void))
-     'tr:class:local-table #t)))
+     #t)))

--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt
@ -65,5 +65,12 @@
  (opt-lambda opt-lambda)
  (kw-lambda kw-lambda)
  (tail-position typechecker:called-in-tail-position #:mark)
+  (tr:class tr:class #:mark)
+  (tr:class:top-level tr:class:top-level)
+  (tr:class:super-new tr:class:super-new)
+  (tr:class:type-annotation tr:class:type-annotation)
+  (tr:class:super tr:class:super)
+  (tr:class:local-table tr:class:local-table)
+  (tr:class:method tr:class:method)
  )

--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@ -324,7 +324,7 @@
  ;; trawl the body for top-level expressions
  (define make-methods-stx (hash-ref parse-info 'make-methods))
  (define top-level-exprs
-    (trawl-for-property make-methods-stx 'tr:class:top-level))
+    (trawl-for-property make-methods-stx tr:class:top-level-property))
  ;; augment annotations go in their own table, because they're
  ;; the only kind of type annotation that is allowed to be duplicate
  ;; (i.e., m can have type Integer -> Integer and an augment type of
@ -336,7 +336,7 @@
  (do-timestamp "built annotation table")
  ;; find the `super-new` call (or error if missing)
  (define super-new-stxs
-    (trawl-for-property make-methods-stx 'tr:class:super-new))
+    (trawl-for-property make-methods-stx tr:class:super-new-property))
  (define super-new-stx (check-super-new-exists super-new-stxs))
  (define-values (provided-pos-args provided-super-inits)
    (if super-new-stx
@ -390,7 +390,7 @@
  (do-timestamp "built self type")
  ;; trawl the body for the local name table
  (define locals
-    (trawl-for-property make-methods-stx 'tr:class:local-table))
+    (trawl-for-property make-methods-stx tr:class:local-table-property))
  (define-values (local-method-table local-private-table local-field-table
                  local-private-field-table local-init-table
                  local-init-rest-table
@ -434,8 +434,8 @@
    (for ([stx top-level-exprs]
          ;; avoid checking these to avoid duplication and to avoid checking
          ;; ignored expressions
-          #:unless (syntax-property stx 'tr:class:super-new)
-          #:unless (syntax-property stx 'tr:class:type-annotation))
+          #:unless (tr:class:super-new-property stx)
+          #:unless (tr:class:type-annotation-property stx))
      (tc-expr stx)))
  (do-timestamp "checked other top-level exprs")
  (with-lexical-env/extend lexical-names/top-level lexical-types/top-level
@ -444,7 +444,8 @@
                       inits))
  (do-timestamp "checked field initializers")
  ;; trawl the body and find methods and type-check them
-  (define meth-stxs (trawl-for-property make-methods-stx 'tr:class:method))
+  (define meth-stxs
+    (trawl-for-property make-methods-stx tr:class:method-property))
  (define checked-method-types
    (with-lexical-env/extend lexical-names lexical-types
      (check-methods (append (hash-ref parse-info 'pubment-names)
@ -770,7 +771,7 @@
                       meths methods self-type)
  (for/fold ([checked '()])
            ([meth meths])
-    (define method-name (syntax-property meth 'tr:class:method))
+    (define method-name (tr:class:method-property meth))
    (define external-name (dict-ref internal-external-mapping method-name #f))
    (define maybe-expected (and external-name (dict-ref methods external-name #f)))
    (cond [(and maybe-expected
@ -804,7 +805,7 @@
 ;; Type-check private methods
 (define (check-private-methods stxs names types self-type)
  (for ([stx stxs])
-    (define method-name (syntax-property stx 'tr:class:method))
+    (define method-name (tr:class:method-property stx))
    (define private? (set-member? names method-name))
    (define annotation (dict-ref types method-name #f))
    (cond [(and private? annotation)
@ -1074,18 +1075,18 @@
               (tc-error/expr "init argument ~a not accepted by superclass"
                              init-id)))]))

-;; Syntax -> Listof<Syntax>
+;; Syntax (Syntax -> Any) -> Listof<Syntax>
 ;; Look through the expansion of the class macro in search for
 ;; syntax with some property (e.g., methods)
-(define (trawl-for-property form prop)
+(define (trawl-for-property form accessor)
  (define (recur-on-all stx-list)
-    (apply append (map (λ (stx) (trawl-for-property stx prop))
+    (apply append (map (λ (stx) (trawl-for-property stx accessor))
                       (syntax->list stx-list))))
  (syntax-parse form
    #:literals (let-values letrec-values #%plain-app
                #%plain-lambda letrec-syntaxes+values)
    [stx
-     #:when (syntax-property form prop)
+     #:when (accessor #'stx)
     (list form)]
    [(let-values (b ...) body ...)
     (recur-on-all #'(b ... body ...))]
@ -1286,7 +1287,7 @@
       m)
     (define annotated-self-param
       (type-ascription-property #'self-param self-type))
-     #`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type))
+     #`(let-values ([(#,(type-label-property #'meth-name method-type))
                     ;; attach source location to the lambda in order to
                     ;; obtain better error messages for arity errors
                     #,(quasisyntax/loc stx
@ -1299,15 +1300,15 @@
                                   core-body ...)))
                     method-body ...)])
       m)
-     #`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type))
-                     #,(syntax-property
+     #`(let-values ([(#,(type-label-property #'meth-name method-type))
+                     #,(kw-lambda-property
                        #`(let-values (((core)
                                        ;; see comment above
                                        #,(quasisyntax/loc stx
                                           (#%plain-lambda (param ...)
                                                           core-body ...))))
                            method-body ...)
-                        'kw-lambda #t)])
+                        #t)])
         m)]
    [_ (tc-error "annotate-method: internal error")]))

--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
@ -234,9 +234,8 @@
      (int-err "bad form input to tc-expr: ~a" form))
    (syntax-parse form
      #:literal-sets (kernel-literals tc-expr-literals)
-      [stx
-       ;; a class: generated class
-       #:when (syntax-property form 'tr:class)
+      ;; a TR-annotated class
+      [stx:tr:class^
       (check-class form expected)
       expected]
      [stx:exn-handlers^
@ -374,8 +373,7 @@
  (define (internal-tc-expr form)
    (syntax-parse form
      #:literal-sets (kernel-literals tc-expr-literals)
-      [stx
-       #:when (syntax-property form 'tr:class)
+      [stx:tr:class^
       (ret (check-class form #f))]
      ;;
      [stx:exn-handlers^
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
@ -159,10 +159,8 @@
  (parameterize ([current-orig-stx form])
    (syntax-parse form
      #:literal-sets (kernel-literals)
-      ;; need to special case this
-      ;; FIXME: is there a better way?
-      [stx
-       #:when (syntax-property form 'tr:class)
+      ;; need to special case this to avoid errors at top-level
+      [stx:tr:class^
       (tc-expr #'stx)]

      ;; these forms we have been instructed to ignore