suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Revise TR classes & docs based on feedback

Browse Source
This commit is contained in:
Asumu Takikawa 2014-01-29 16:18:33 -05:00
parent e7e354f69a
commit 1c6c0855f7
7 changed files with 160 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl
View File

@ -28,11 +28,11 @@ For a friendly introduction, see the companion manual
@include-section["reference/types.scrbl"] @include-section["reference/types.scrbl"]
@include-section["reference/special-forms.scrbl"] @include-section["reference/special-forms.scrbl"]
@include-section["reference/libraries.scrbl"] @include-section["reference/libraries.scrbl"]
@include-section["reference/typed-classes.scrbl"]
@include-section["reference/utilities.scrbl"] @include-section["reference/utilities.scrbl"]
@include-section["reference/exploring-types.scrbl"] @include-section["reference/exploring-types.scrbl"]
@include-section["reference/no-check.scrbl"] @include-section["reference/no-check.scrbl"]
@include-section["reference/typed-regions.scrbl"] @include-section["reference/typed-regions.scrbl"]
@include-section["reference/typed-classes.scrbl"]
@include-section["reference/optimization.scrbl"] @include-section["reference/optimization.scrbl"]
@include-section["reference/legacy.scrbl"] @include-section["reference/legacy.scrbl"]
@include-section["reference/compatibility-languages.scrbl"] @include-section["reference/compatibility-languages.scrbl"]

1
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -22,7 +22,6 @@
(only-in (types numeric-tower) [-Number N]) (only-in (types numeric-tower) [-Number N])
(only-in (rep type-rep) (only-in (rep type-rep)
make-ClassTop make-ClassTop
make-Instance
make-Name make-Name
make-ValuesDots make-ValuesDots
make-MPairTop make-MPairTop

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

@ -4,22 +4,26 @@
(require (rename-in racket/class [class untyped-class]) (require (rename-in racket/class [class untyped-class])
"colon.rkt" "colon.rkt"
"../typecheck/internal-forms.rkt"
(for-syntax (for-syntax
racket/base racket/base
racket/class racket/class
racket/dict racket/dict
racket/list racket/list
racket/match racket/match
racket/pretty ;; get rid of this later
racket/syntax 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/flatten-begin
syntax/id-table syntax/id-table
syntax/kerncase syntax/kerncase
syntax/parse syntax/parse
syntax/stx syntax/stx
unstable/list unstable/list
(for-template "../typecheck/internal-forms.rkt") "../private/syntax-properties.rkt"
"../utils/tc-utils.rkt" "../utils/tc-utils.rkt"
"../types/utils.rkt")) "../types/utils.rkt"))
@ -95,12 +99,13 @@
extract-names clause init-clause get-optional-inits))) extract-names clause init-clause get-optional-inits)))
(begin-for-syntax (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. ;; 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) ;; kind - the kind of clause (e.g., init, field)
;; ids - list of the ids defined in this clause ;; 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)) (struct clause (stx kind ids types))
;; An InitClause is a (init-clause Syntax Id Listof<Syntax> Boolean) ;; An InitClause is a (init-clause Syntax Id Listof<Syntax> Boolean)
@ -114,6 +119,9 @@
;; class clauses such as init or field. ;; class clauses such as init or field.
(struct non-clause (stx)) (struct non-clause (stx))
(define-literal-set class-literals
(:))
(define-splicing-syntax-class maybe-type-parameter (define-splicing-syntax-class maybe-type-parameter
(pattern (~seq #:forall type-variable:id) (pattern (~seq #:forall type-variable:id)
#:attr type-variables #'(type-variable)) #:attr type-variables #'(type-variable))
@ -122,23 +130,29 @@
(pattern (~seq) (pattern (~seq)
#:attr type-variables #'())) #: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 (define-syntax-class init-decl
#:attributes (optional? ids type form) #:attributes (optional? ids type form)
#:literal-sets (class-literals)
(pattern id:id (pattern id:id
#:attr optional? #f #:attr optional? #f
#:with ids #'(id id) #:with ids #'(id id)
#:attr type #f #:attr type #f
#:with form this-syntax) #:with form this-syntax)
(pattern (id:id (~datum :) type:expr) (pattern (id:id : type:expr)
#:attr optional? #f #:attr optional? #f
#:with ids #'(id id) #:with ids #'(id id)
#:with form #'id) #:with form #'id)
(pattern (ren:renamed (~optional (~seq (~datum :) type:expr))) (pattern (ren:renamed (~optional (~seq : type:expr)))
#:attr optional? #f #:attr optional? #f
#:with ids #'ren.ids #:with ids #'ren.ids
#:with form #'(ren)) #:with form #'(ren))
(pattern (mren:maybe-renamed (pattern (mren:maybe-renamed
(~optional (~seq (~datum :) type:expr)) (~optional (~seq : type:expr))
default-value:expr) default-value:expr)
#:attr optional? #t #:attr optional? #t
#:with ids #'mren.ids #:with ids #'mren.ids
@ -146,45 +160,74 @@
(define-syntax-class field-decl (define-syntax-class field-decl
#:attributes (ids type form) #:attributes (ids type form)
#:literal-sets (class-literals)
(pattern (mren:maybe-renamed (pattern (mren:maybe-renamed
(~optional (~seq (~datum :) type:expr)) (~optional (~seq : type:expr))
default-value:expr) default-value:expr)
#:with ids #'mren.ids #:with ids #'mren.ids
#:with form #'(mren default-value))) #:with form #'(mren default-value)))
(define-syntax-class method-decl (define-syntax-class method-decl
#:attributes (ids type form) #:attributes (ids type form)
#:literal-sets (class-literals)
(pattern mren:maybe-renamed (pattern mren:maybe-renamed
#:with ids #'mren.ids #:with ids #'mren.ids
#:attr type #f #:attr type #f
#:with form this-syntax) #:with form this-syntax)
(pattern (mren:maybe-renamed (~datum :) type:expr) (pattern (mren:maybe-renamed : type:expr)
#:with ids #'mren.ids #:with ids #'mren.ids
#:with form #'mren)) #:with form #'mren))
(define-syntax-class private-decl (define-syntax-class private-decl
#:attributes (id type form) #:attributes (id type form)
#:literal-sets (class-literals)
(pattern id:id (pattern id:id
#:attr type #f #:attr type #f
#:with form this-syntax) #:with form this-syntax)
(pattern (id:id (~datum :) type:expr) (pattern (id:id : type:expr)
#:with form #'id)) #:with form #'id))
(define-syntax-class renamed (define-syntax-class renamed
#:attributes (ids)
(pattern (internal-id:id external-id:id) (pattern (internal-id:id external-id:id)
#:with ids #'(internal-id external-id))) #:with ids #'(internal-id external-id)))
(define-syntax-class maybe-renamed (define-syntax-class maybe-renamed
#:attributes (ids)
(pattern id:id (pattern id:id
#:with ids #'(id id)) #:with ids #'(id id))
(pattern ren:renamed (pattern ren:renamed
#:with ids #'ren.ids)) #: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 (define-syntax-class class-clause
(pattern ((~and clause-name (~or (~literal init) (pattern (clause-name:init-like-clause-names names:init-decl ...)
(~literal init-field))) ;; FIXME: in the future, use a data structure and
names:init-decl ...)
;; in the future, use a data structure and
;; make this an attribute instead to represent ;; make this an attribute instead to represent
;; internal and external names ;; internal and external names
#:attr data #:attr data
@ -203,29 +246,13 @@
#'field #'field
(stx->list #'(names.ids ...)) (stx->list #'(names.ids ...))
(attribute names.type))) (attribute names.type)))
(pattern ((~and clause-name (~or (~literal inherit-field) (pattern (clause-name:method-like-clause-names names:method-decl ...)
(~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 ...)
#:attr data #:attr data
(clause #'(clause-name names.form ...) (clause #'(clause-name names.form ...)
#'clause-name #'clause-name
(stx->list #'(names.ids ...)) (stx->list #'(names.ids ...))
(attribute names.type))) (attribute names.type)))
(pattern ((~and clause-name (~or (~literal private) (pattern (clause-name:private-like-clause-names names:private-decl ...)
(~literal abstract)))
names:private-decl ...)
#:attr data #:attr data
(clause #'(clause-name names.form ...) (clause #'(clause-name names.form ...)
#'clause-name #'clause-name
@ -233,21 +260,19 @@
(attribute names.type)))) (attribute names.type))))
(define-syntax-class class-clause-or-other (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))) (pattern e:expr #:attr data (non-clause #'e)))
;; Listof<Clause> -> Dict<Identifier, Names> ;; Listof<Clause> -> Dict<Identifier, Names>
;; Extract names from init, public, etc. clauses ;; Extract names from init, public, etc. clauses
(define (extract-names clauses) (define (extract-names clauses)
(for/fold ([clauses (make-immutable-free-id-table)]) (for/fold ([clauses (make-immutable-free-id-table)])
([clause clauses]) ([clause (in-list clauses)])
(if (dict-has-key? clauses (clause-kind clause)) (dict-update clauses (clause-kind clause)
(dict-update clauses (clause-kind clause) (λ (old-names)
(λ (old-names) (append old-names (clause-ids clause)))
(append old-names (clause-ids clause)))) '())))
(dict-set clauses
(clause-kind clause)
(clause-ids clause)))))
;; FIXME: less magic ;; FIXME: less magic
;; magic used to disarm syntax after expansion ;; magic used to disarm syntax after expansion
@ -267,7 +292,7 @@
[else [else
(define stx (disarm (class-expand (car stxs)))) (define stx (disarm (class-expand (car stxs))))
(syntax-parse stx (syntax-parse stx
#:literals (begin define-syntaxes) #:literals (begin define-syntaxes define-values)
[(begin . _) [(begin . _)
(loop (append (flatten-begin stx) (cdr stxs)))] (loop (append (flatten-begin stx) (cdr stxs)))]
;; Handle syntax definitions in the expanded syntax ;; Handle syntax definitions in the expanded syntax
@ -301,7 +326,6 @@
(define-syntax (class stx) (define-syntax (class stx)
(syntax-parse stx (syntax-parse stx
[(_ super forall:maybe-type-parameter e ...) [(_ super forall:maybe-type-parameter e ...)
;; FIXME: potentially needs to expand super clause?
(define class-ctx (generate-class-expand-context)) (define class-ctx (generate-class-expand-context))
(define def-ctx (syntax-local-make-definition-context)) (define def-ctx (syntax-local-make-definition-context))
(define expanded-stx (define expanded-stx
@ -318,30 +342,15 @@
(internal-definition-context-seal def-ctx) (internal-definition-context-seal def-ctx)
(define-values (annotated-methods other-top-level private-fields) (define-values (annotated-methods other-top-level private-fields)
(process-class-contents others name-dict)) (process-class-contents others name-dict))
(define annotated-super (define annotated-super (tr:class:super-property #'super #t))
(syntax-property #'super 'tr:class:super #t))
(define optional-inits (get-optional-inits clauses)) (define optional-inits (get-optional-inits clauses))
(syntax-property (ignore
(syntax-property (tr:class
#`(let-values () #`(let-values ()
#,(internal #,(internal (make-class-name-table (attribute forall.type-variables)
;; FIXME: maybe put this in a macro and/or a syntax class private-fields
;; so that it's easier to deal with optional-inits
#`(class-internal name-dict))
(#: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 '()))))
(untyped-class #,annotated-super (untyped-class #,annotated-super
#,@(map clause-stx clauses) #,@(map clause-stx clauses)
;; construct in-body type annotations for clauses ;; construct in-body type annotations for clauses
@ -350,19 +359,20 @@
(match-define (clause _1 _2 ids types) a-clause) (match-define (clause _1 _2 ids types) a-clause)
(for/list ([id ids] [type types] (for/list ([id ids] [type types]
#:when type) #:when type)
(syntax-property ;; FIXME: it might be cleaner to use the type-label-property
(syntax-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) #`(: #,(if (stx-pair? id) (stx-car id) id)
#,type) #,type)
'tr:class:top-level #t) #t)
'tr:class:type-annotation #t)))) #t))))
#,@(map non-clause-stx annotated-methods) #,@(map non-clause-stx annotated-methods)
#,(syntax-property #,(tr:class:top-level-property
#`(begin #,@(map non-clause-stx other-top-level)) #`(begin #,@(map non-clause-stx other-top-level))
'tr:class:top-level #t) #t)
#,(make-locals-table name-dict private-fields))) #,(make-locals-table name-dict private-fields)))))])]))
'tr:class #t)
'typechecker:ignore #t)])]))
(begin-for-syntax (begin-for-syntax
;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>> ;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>>
@ -381,15 +391,8 @@
;; if it's a method definition for a declared method, then ;; if it's a method definition for a declared method, then
;; mark it as something to type-check ;; mark it as something to type-check
[(define-values (id) . rst) [(define-values (id) . rst)
#:when (memf (λ (n) (free-identifier=? #'id n)) #:when (method-id? #'id name-dict)
(append (stx-map stx-car (dict-ref name-dict #'public '())) (values (cons (non-clause (tr:class:method-property stx (syntax-e #'id)))
(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)))
methods) methods)
rest-top private-fields)] rest-top private-fields)]
;; private field definition ;; private field definition
@ -401,19 +404,19 @@
;; special : annotation for augment interface ;; special : annotation for augment interface
[(: name:id type:expr #:augment augment-type:expr) [(: name:id type:expr #:augment augment-type:expr)
(define new-clause (define new-clause
(non-clause (syntax-property #'(quote-syntax (:-augment name augment-type)) (non-clause (tr:class:type-annotation-property
'tr:class:type-annotation #t))) #'(quote-syntax (:-augment name augment-type)) #t)))
(define plain-annotation (define plain-annotation
(non-clause (syntax-property (syntax/loc stx (: name type)) (non-clause (tr:class:type-annotation-property
'tr:class:type-annotation #t))) (syntax/loc stx (: name type)) #t)))
(values methods (values methods
(append rest-top (list plain-annotation new-clause)) (append rest-top (list plain-annotation new-clause))
private-fields)] private-fields)]
;; Just process this to add the property ;; Just process this to add the property
[(: name:id type:expr) [(: name:id type:expr)
(define plain-annotation (define plain-annotation
(non-clause (syntax-property (syntax/loc stx (: name type)) (non-clause (tr:class:type-annotation-property
'tr:class:type-annotation #t))) (syntax/loc stx (: name type)) #t)))
(values methods (values methods
(append rest-top (list plain-annotation)) (append rest-top (list plain-annotation))
private-fields)] private-fields)]
@ -422,14 +425,24 @@
(super-make-object init-expr ...) (super-make-object init-expr ...)
(super-instantiate (init-expr ...) [name expr] ...)) (super-instantiate (init-expr ...) [name expr] ...))
(define new-non-clause (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)) (values methods (append rest-top (list new-non-clause))
private-fields)] private-fields)]
[_ (values methods (append rest-top (list content)) [_ (values methods (append rest-top (list content))
private-fields)]))) 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-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) (define (get-optional-inits clauses)
(flatten (flatten
(for/list ([clause clauses] (for/list ([clause clauses]
@ -451,6 +464,28 @@
"unsupported class clause: ~a" "unsupported class clause: ~a"
(syntax-e form))))) (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 ;; This is a neat/horrible trick
;; ;;
;; In order to detect the mappings that class-internal.rkt has ;; In order to detect the mappings that class-internal.rkt has
@ -478,7 +513,7 @@
(define augment-names (define augment-names
(append (stx-map stx-car (dict-ref name-dict #'pubment '())) (append (stx-map stx-car (dict-ref name-dict #'pubment '()))
(stx-map stx-car (dict-ref name-dict #'augment '())))) (stx-map stx-car (dict-ref name-dict #'augment '()))))
(syntax-property (tr:class:local-table-property
#`(let-values ([(#,@public-names) #`(let-values ([(#,@public-names)
(values #,@(map (λ (stx) #`(λ () (#,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx)))
public-names))] public-names))]
@ -510,5 +545,5 @@
(values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx)))
augment-names))]) augment-names))])
(void)) (void))
'tr:class:local-table #t))) #t)))

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt
View File

@ -65,5 +65,12 @@
(opt-lambda opt-lambda) (opt-lambda opt-lambda)
(kw-lambda kw-lambda) (kw-lambda kw-lambda)
(tail-position typechecker:called-in-tail-position #:mark) (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)
) )

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

@ -324,7 +324,7 @@
;; trawl the body for top-level expressions ;; trawl the body for top-level expressions
(define make-methods-stx (hash-ref parse-info 'make-methods)) (define make-methods-stx (hash-ref parse-info 'make-methods))
(define top-level-exprs (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 ;; augment annotations go in their own table, because they're
;; the only kind of type annotation that is allowed to be duplicate ;; 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 ;; (i.e., m can have type Integer -> Integer and an augment type of
@ -336,7 +336,7 @@
(do-timestamp "built annotation table") (do-timestamp "built annotation table")
;; find the `super-new` call (or error if missing) ;; find the `super-new` call (or error if missing)
(define super-new-stxs (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 super-new-stx (check-super-new-exists super-new-stxs))
(define-values (provided-pos-args provided-super-inits) (define-values (provided-pos-args provided-super-inits)
(if super-new-stx (if super-new-stx
@ -390,7 +390,7 @@
(do-timestamp "built self type") (do-timestamp "built self type")
;; trawl the body for the local name table ;; trawl the body for the local name table
(define locals (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 (define-values (local-method-table local-private-table local-field-table
local-private-field-table local-init-table local-private-field-table local-init-table
local-init-rest-table local-init-rest-table
@ -434,8 +434,8 @@
(for ([stx top-level-exprs] (for ([stx top-level-exprs]
;; avoid checking these to avoid duplication and to avoid checking ;; avoid checking these to avoid duplication and to avoid checking
;; ignored expressions ;; ignored expressions
#:unless (syntax-property stx 'tr:class:super-new) #:unless (tr:class:super-new-property stx)
#:unless (syntax-property stx 'tr:class:type-annotation)) #:unless (tr:class:type-annotation-property stx))
(tc-expr stx))) (tc-expr stx)))
(do-timestamp "checked other top-level exprs") (do-timestamp "checked other top-level exprs")
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level (with-lexical-env/extend lexical-names/top-level lexical-types/top-level
@ -444,7 +444,8 @@
inits)) inits))
(do-timestamp "checked field initializers") (do-timestamp "checked field initializers")
;; trawl the body and find methods and type-check them ;; 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 (define checked-method-types
(with-lexical-env/extend lexical-names lexical-types (with-lexical-env/extend lexical-names lexical-types
(check-methods (append (hash-ref parse-info 'pubment-names) (check-methods (append (hash-ref parse-info 'pubment-names)
@ -770,7 +771,7 @@
meths methods self-type) meths methods self-type)
(for/fold ([checked '()]) (for/fold ([checked '()])
([meth meths]) ([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 external-name (dict-ref internal-external-mapping method-name #f))
(define maybe-expected (and external-name (dict-ref methods external-name #f))) (define maybe-expected (and external-name (dict-ref methods external-name #f)))
(cond [(and maybe-expected (cond [(and maybe-expected
@ -804,7 +805,7 @@
;; Type-check private methods ;; Type-check private methods
(define (check-private-methods stxs names types self-type) (define (check-private-methods stxs names types self-type)
(for ([stx stxs]) (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 private? (set-member? names method-name))
(define annotation (dict-ref types method-name #f)) (define annotation (dict-ref types method-name #f))
(cond [(and private? annotation) (cond [(and private? annotation)
@ -1074,18 +1075,18 @@
(tc-error/expr "init argument ~a not accepted by superclass" (tc-error/expr "init argument ~a not accepted by superclass"
init-id)))])) init-id)))]))
;; Syntax -> Listof<Syntax> ;; Syntax (Syntax -> Any) -> Listof<Syntax>
;; Look through the expansion of the class macro in search for ;; Look through the expansion of the class macro in search for
;; syntax with some property (e.g., methods) ;; 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) (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->list stx-list))))
(syntax-parse form (syntax-parse form
#:literals (let-values letrec-values #%plain-app #:literals (let-values letrec-values #%plain-app
#%plain-lambda letrec-syntaxes+values) #%plain-lambda letrec-syntaxes+values)
[stx [stx
#:when (syntax-property form prop) #:when (accessor #'stx)
(list form)] (list form)]
[(let-values (b ...) body ...) [(let-values (b ...) body ...)
(recur-on-all #'(b ... body ...))] (recur-on-all #'(b ... body ...))]
@ -1286,7 +1287,7 @@
m) m)
(define annotated-self-param (define annotated-self-param
(type-ascription-property #'self-param self-type)) (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 ;; attach source location to the lambda in order to
;; obtain better error messages for arity errors ;; obtain better error messages for arity errors
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
@ -1299,15 +1300,15 @@
core-body ...))) core-body ...)))
method-body ...)]) method-body ...)])
m) m)
#`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type)) #`(let-values ([(#,(type-label-property #'meth-name method-type))
#,(syntax-property #,(kw-lambda-property
#`(let-values (((core) #`(let-values (((core)
;; see comment above ;; see comment above
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(#%plain-lambda (param ...) (#%plain-lambda (param ...)
core-body ...)))) core-body ...))))
method-body ...) method-body ...)
'kw-lambda #t)]) #t)])
m)] m)]
[_ (tc-error "annotate-method: internal error")])) [_ (tc-error "annotate-method: internal error")]))

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -234,9 +234,8 @@
(int-err "bad form input to tc-expr: ~a" form)) (int-err "bad form input to tc-expr: ~a" form))
(syntax-parse form (syntax-parse form
#:literal-sets (kernel-literals tc-expr-literals) #:literal-sets (kernel-literals tc-expr-literals)
[stx ;; a TR-annotated class
;; a class: generated class [stx:tr:class^
#:when (syntax-property form 'tr:class)
(check-class form expected) (check-class form expected)
expected] expected]
[stx:exn-handlers^ [stx:exn-handlers^
@ -374,8 +373,7 @@
(define (internal-tc-expr form) (define (internal-tc-expr form)
(syntax-parse form (syntax-parse form
#:literal-sets (kernel-literals tc-expr-literals) #:literal-sets (kernel-literals tc-expr-literals)
[stx [stx:tr:class^
#:when (syntax-property form 'tr:class)
(ret (check-class form #f))] (ret (check-class form #f))]
;; ;;
[stx:exn-handlers^ [stx:exn-handlers^

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -159,10 +159,8 @@
(parameterize ([current-orig-stx form]) (parameterize ([current-orig-stx form])
(syntax-parse form (syntax-parse form
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
;; need to special case this ;; need to special case this to avoid errors at top-level
;; FIXME: is there a better way? [stx:tr:class^
[stx
#:when (syntax-property form 'tr:class)
(tc-expr #'stx)] (tc-expr #'stx)]
;; these forms we have been instructed to ignore ;; these forms we have been instructed to ignore