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

Rewrite TR class form to preserve abstractions

Browse Source 
This uses a technique discovered by Ryan and Dan that
allows the typed class macro to function without invasively
local-expanding the entire class macro (using its private
context information).

Instead, it expands into many helper macros inside the
normal class body and communicates among them using
`syntax-local-value` and compile-time state within the
class body.

This rewrite didn't save that many lines, but it did
reduce the amount of magic that's used.
This commit is contained in:
Asumu Takikawa 2014-10-09 00:40:11 -04:00
parent d17fca3838
commit 725cb99f4a
13 changed files with 660 additions and 632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt
View File

@ -2,7 +2,7 @@
(require typed/mred/mred (require typed/mred/mred
typed/framework/framework typed/framework/framework
racket/class typed/racket/class
string-constants) string-constants)
(require/typed framework (require/typed framework

17
pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl
View File

@ -224,6 +224,23 @@ additional provides all other bindings from @racketmodname[racket/class].
@define/foo-content[d/pr-element] @define/foo-content[d/pr-element]
} }
@deftogether[(@defform[(init init-decl ...)]
@defform[(init-field init-decl ...)]
@defform[(field field-decl ...)]
@defform[(inherit-field field-decl ...)]
@defform[(init-rest id/type)]
@defform[(public maybe-renamed/type ...)]
@defform[(pubment maybe-renamed/type ...)]
@defform[(override maybe-renamed/type ...)]
@defform[(augment maybe-renamed/type ...)]
@defform[(private id/type ...)]
@defform[(inherit maybe-renamed/type ...)])]{
These forms are mostly equivalent to the forms of the same names from
the @racketmodname[racket/class] library and will expand to them. However,
they also allow the initialization argument, field, or method names to be
annotated with types as described above for the @racket[class] form.
}
@section{Types} @section{Types}
@defform[#:literals (init init-field init-rest field augment) @defform[#:literals (init init-field init-rest field augment)

218
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-clauses.rkt Normal file
View File

@ -0,0 +1,218 @@
#lang racket/base
;; This module provides helper syntax classes and macros that are used
;; to implement the typed class macro. It's separated in order to allow
;; other parts of TR to use the bindings of init, public, etc. without
;; requiring prims.rkt
(require (prefix-in untyped: racket/class)
"colon.rkt"
(for-syntax racket/base
syntax/parse
syntax/stx
"../private/syntax-properties.rkt"))
(provide (for-syntax class-clause
clause
clause?
clause-stx
clause-kind
clause-ids
init-clause
init-clause?
init-clause-optional?)
init
init-field
field
inherit-field
init-rest
public
pubment
override
augment
private
inherit)
;; for tests
(module+ internal (provide (for-syntax init-decl)))
(begin-for-syntax
;; 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 a type is not provided
(struct clause (stx kind ids types) #:transparent)
;; An InitClause is a (init-clause Syntax Id Listof<Syntax> Boolean)
;;
;; interp. an init class clause
(struct init-clause clause (optional?) #:transparent)
(define-literal-set class-literals
(:))
;; 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 : type:expr)
#:attr optional? #f
#:with ids #'(id id)
#:with form #'id)
(pattern (ren:renamed (~optional (~seq : type:expr)))
#:attr optional? #f
#:with ids #'ren.ids
#:with form #'(ren))
(pattern (mren:maybe-renamed
(~optional (~seq : type:expr))
default-value:expr)
#:attr optional? #t
#:with ids #'mren.ids
#:with form #'(mren default-value)))
(define-syntax-class field-decl
#:attributes (ids type form)
#:literal-sets (class-literals)
(pattern (mren:maybe-renamed
(~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 : type:expr)
#:with ids #'mren.ids
#:with form #'mren))
(define-syntax-class private-decl
#:attributes (ids type form)
#:literal-sets (class-literals)
(pattern id:id
#:attr ids #'id
#:attr type #f
#:with form this-syntax)
(pattern (id:id : type:expr)
#:attr ids #'id
#: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 untyped:init)
(~literal untyped: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 untyped:inherit-field)
(~literal untyped:public)
(~literal untyped:pubment)
(~literal untyped:public-final)
(~literal untyped:override)
(~literal untyped:overment)
(~literal untyped:override-final)
(~literal untyped:augment)
(~literal untyped:augride)
(~literal untyped:augment-final)
(~literal untyped:inherit)
(~literal untyped:inherit/super)
(~literal untyped:inherit/inner)
(~literal untyped:rename-super))))
(define-syntax-class private-like-clause-names
(pattern (~or (~literal untyped:private)
(~literal untyped:abstract))))
(define-syntax-class class-clause
(pattern (clause-name:init-like-clause-names names:init-decl ...)
#:attr data
(init-clause #'(clause-name names.form ...)
#'clause-name
(stx->list #'(names.ids ...))
(attribute names.type)
(attribute names.optional?)))
(pattern ((~literal untyped:init-rest) name:private-decl)
#:attr data (clause #'(untyped:init-rest name.form)
#'untyped:init-rest
(stx->list #'(name.ids))
(list (attribute name.type))))
(pattern ((~literal untyped:field) names:field-decl ...)
#:attr data (clause #'(untyped:field names.form ...)
#'untyped:field
(stx->list #'(names.ids ...))
(attribute names.type)))
(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 (clause-name:private-like-clause-names names:private-decl ...)
#:attr data
(clause #'(clause-name names.form ...)
#'clause-name
(stx->list #'(names.ids ...))
(attribute names.type)))))
;; overriden declaration forms
(define-syntax (define-decl-forms stx)
(syntax-parse stx
[(_ ((?clause-name:id ?orig-name:id ?decl-class:id) ...))
#'(begin (define-syntax (?clause-name stx)
(syntax-parse stx
[(_ (~var ??decl ?decl-class) (... ...))
#`(begin #,@(for/list ([id (in-list (attribute ??decl.ids))]
[type (in-list (attribute ??decl.type))]
#:when type)
(tr:class:top-level-property
(tr:class:type-annotation-property
#`(: #,(if (stx-pair? id) (stx-car id) id) #,type)
#t)
#t))
;; set a property here to avoid taint-related issues because
;; we can't transplant the identifiers in the expansion (into the
;; class local table) in certain cases
#,(tr:class:clause-ids-property
#`(?orig-name #,@(attribute ??decl.form))
(attribute ??decl.ids)))]))
...)]))
(define-decl-forms ([init untyped:init init-decl]
[init-field untyped:init-field init-decl]
[field untyped:field field-decl]
[inherit-field untyped:inherit-field method-decl]
[init-rest untyped:init-rest private-decl]
[public untyped:public method-decl]
[pubment untyped:pubment method-decl]
[override untyped:override method-decl]
[augment untyped:augment method-decl]
[private untyped:private private-decl]
[inherit untyped:inherit method-decl]))

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

@ -2,13 +2,8 @@
;; This module provides TR primitives for classes and objects ;; This module provides TR primitives for classes and objects
(require (rename-in (except-in racket/class (require (prefix-in untyped: racket/class)
define/public "class-clauses.rkt"
define/override
define/pubment
define/augment
define/private)
[class untyped-class])
"colon.rkt" "colon.rkt"
"../typecheck/internal-forms.rkt" "../typecheck/internal-forms.rkt"
"../private/class-literals.rkt" "../private/class-literals.rkt"
@ -16,21 +11,12 @@
(for-syntax (for-syntax
racket/base racket/base
racket/class racket/class
racket/dict
racket/list racket/list
racket/match racket/match
racket/syntax racket/syntax
;; 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/kerncase
syntax/parse syntax/parse
syntax/stx syntax/stx
unstable/list
"annotate-classes.rkt" "annotate-classes.rkt"
"../private/syntax-properties.rkt" "../private/syntax-properties.rkt"
"../utils/tc-utils.rkt")) "../utils/tc-utils.rkt"))
@ -42,9 +28,21 @@
define/override define/override
define/pubment define/pubment
define/augment define/augment
define/private) define/private
;; override these for type annotations
init
init-field
field
inherit-field
init-rest
public
pubment
override
augment
private
inherit)
;; overriden forms ;; overriden define forms
(define-syntax-rule (define-define/class-kw ((?id ?class-kw) ...)) (define-syntax-rule (define-define/class-kw ((?id ?class-kw) ...))
(begin (define-syntax (?id stx) (begin (define-syntax (?id stx)
(syntax-parse stx (syntax-parse stx
@ -55,401 +53,220 @@
...)) ...))
(define-define/class-kw (define-define/class-kw
([define/public public] ([define/public public]
[define/override override] [define/override override]
[define/pubment pubment] [define/pubment pubment]
[define/augment augment] [define/augment augment]
[define/private private])) [define/private private]))
(begin-for-syntax (begin-for-syntax
;; TRClassInfo stores information in the class macro that lets the
;; TR class helper macros coordinate amongst each other.
;;
;; It is a (tr-class-info List<Clause> List<Identifier>)
;;
;; clauses - stores in reverse order all class clauses that appeared
;; in the class expression
;; private-fields - a list of private field names
(struct tr-class-info (clauses private-fields) #:mutable)
;; forms that are not allowed by Typed Racket yet ;; forms that are not allowed by Typed Racket yet
(define unsupported-forms (define unsupported-forms
(list (quote-syntax augride) (list (quote-syntax untyped:augride)
;; FIXME: see if override contracts are enough ;; FIXME: see if override contracts are enough
;; to keep these at bay or whether they ;; to keep these at bay or whether they
;; need to be handled ;; need to be handled
(quote-syntax public-final) (quote-syntax untyped:public-final)
(quote-syntax override-final) (quote-syntax untyped:override-final)
(quote-syntax augment-final) (quote-syntax untyped:augment-final)
(quote-syntax overment) (quote-syntax untyped:overment)
(quote-syntax abstract) (quote-syntax untyped:abstract)
(quote-syntax rename-super) (quote-syntax untyped:rename-super)
(quote-syntax inherit/super) (quote-syntax untyped:inherit/super)
(quote-syntax inherit/inner) (quote-syntax untyped:inherit/inner)
(quote-syntax rename-inner))) (quote-syntax untyped:rename-inner)))
;; basically the same stop forms that class-internal uses ;; similar to the same stop forms that the class macro uses
(define stop-forms (define stop-forms
(append (kernel-form-identifier-list) (append (kernel-form-identifier-list)
unsupported-forms unsupported-forms
(list (list
(quote-syntax :) (quote-syntax :)
(quote-syntax #%app) (quote-syntax untyped:init)
(quote-syntax lambda) (quote-syntax untyped:field)
(quote-syntax init) (quote-syntax untyped:init-field)
(quote-syntax field) (quote-syntax untyped:init-rest)
(quote-syntax init-field) (quote-syntax untyped:inherit-field)
(quote-syntax init-rest) (quote-syntax untyped:private)
(quote-syntax inherit-field) (quote-syntax untyped:public)
(quote-syntax private) (quote-syntax untyped:override)
(quote-syntax public) (quote-syntax untyped:pubment)
(quote-syntax override) (quote-syntax untyped:augment)
(quote-syntax pubment) (quote-syntax untyped:inherit)
(quote-syntax augment) (quote-syntax untyped:super)
(quote-syntax inherit) (quote-syntax untyped:inner)
(quote-syntax super) (quote-syntax untyped:super-new)
(quote-syntax inner) (quote-syntax untyped:super-instantiate)
(quote-syntax this) (quote-syntax untyped:super-make-object)
(quote-syntax this%) (quote-syntax untyped:inspect))))
(quote-syntax super-new)
(quote-syntax super-instantiate)
(quote-syntax super-make-object)
(quote-syntax inspect)))))
;; export some syntax-time definitions for testing purposes
(module+ internal
(provide (for-syntax init-decl class-clause class-clause-or-other
extract-names clause init-clause get-optional-inits)))
(begin-for-syntax
;; 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 a type is not provided
(struct clause (stx kind ids types))
;; An InitClause is a (init-clause Syntax Id Listof<Syntax> Boolean)
;;
;; interp. an init class clause
(struct init-clause clause (optional?))
;; A NonClause is a (non-clause Syntax)
;;
;; interp. a top-level class expression that is not one of the special
;; class clauses such as init or field.
(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 (~or #:∀ #:forall) (type-variable:id ...)) (pattern (~seq (~or #:∀ #:forall) (type-variable:id ...))
#:attr type-variables #'(type-variable ...)) #:attr type-variables #'(type-variable ...))
(pattern (~seq) (pattern (~seq)
#:attr type-variables #'())) #:attr type-variables #'())))
;; interp: ;; export some syntax-time definitions for testing purposes
;; optional? - optional init arg or not (has default value or not) (module+ internal
;; ids - internal and external id for this argument (provide (for-syntax get-optional-inits)))
;; 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 : type:expr)
#:attr optional? #f
#:with ids #'(id id)
#:with form #'id)
(pattern (ren:renamed (~optional (~seq : type:expr)))
#:attr optional? #f
#:with ids #'ren.ids
#:with form #'(ren))
(pattern (mren:maybe-renamed
(~optional (~seq : type:expr))
default-value:expr)
#:attr optional? #t
#:with ids #'mren.ids
#:with form #'(mren default-value)))
(define-syntax-class field-decl
#:attributes (ids type form)
#:literal-sets (class-literals)
(pattern (mren:maybe-renamed
(~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 : 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 : 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 (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
(init-clause #'(clause-name names.form ...)
#'clause-name
(stx->list #'(names.ids ...))
(attribute names.type)
(attribute names.optional?)))
(pattern ((~literal init-rest) name:private-decl)
#:attr data (clause #'(init-rest name.form)
#'init-rest
(stx->list #'(name.id))
(list (attribute name.type))))
(pattern ((~literal field) names:field-decl ...)
#:attr data (clause #'(field names.form ...)
#'field
(stx->list #'(names.ids ...))
(attribute names.type)))
(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 (clause-name:private-like-clause-names names:private-decl ...)
#:attr data
(clause #'(clause-name names.form ...)
#'clause-name
(stx->list #'(names.id ...))
(attribute names.type))))
(define-syntax-class class-clause-or-other
#: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 (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
(define class-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (disarm stx)
(syntax-disarm stx class-insp))
;; Expand the syntax inside the class body
;; this is mostly cribbed from class-internal.rkt
(define (expand-expressions stxs ctx def-ctx)
(define (class-expand stx)
(local-expand stx ctx stop-forms def-ctx))
(let loop ([stxs stxs])
(cond [(null? stxs) null]
[else
(define stx (disarm (class-expand (car stxs))))
(syntax-parse stx
#:literals (begin define-syntaxes define-values)
[(begin . _)
(loop (append (flatten-begin stx) (cdr stxs)))]
;; Handle syntax definitions in the expanded syntax
;; i.e., macro definitions in the class body
;; see class-internal.rkt as well
[(define-syntaxes (name:id ...) rhs:expr)
(syntax-local-bind-syntaxes
(syntax->list #'(name ...)) #'rhs def-ctx)
(cons stx (loop (cdr stxs)))]
[(define-values (name:id ...) rhs:expr)
(syntax-local-bind-syntaxes
(syntax->list #'(name ...)) #f def-ctx)
(cons stx (loop (cdr stxs)))]
[_ (cons stx (loop (cdr stxs)))])])))
;; add-names-to-intdef-context : Intdef-Ctx Dict<Id, Names> -> Void
;; Establish accessor names in the internal definition context
;; to avoid unbound identifier errors at this level
(define (add-names-to-intdef-context def-ctx name-dict)
(define (add-kind kind)
(define names (map stx-car (dict-ref name-dict kind null)))
(syntax-local-bind-syntaxes names #f def-ctx))
(add-kind #'init-field)
(add-kind #'field)
(add-kind #'public)
(add-kind #'pubment)))
(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 ...)
(define class-ctx (generate-class-expand-context)) (define/with-syntax class-info (generate-temporary))
(define def-ctx (syntax-local-make-definition-context)) (ignore
(define expanded-stx (tr:class
(expand-expressions (syntax->list #'(e ...)) class-ctx def-ctx)) (quasisyntax/loc stx
(syntax-parse expanded-stx (untyped:class #,(tr:class:super-property #'super #t)
[(class-elems:class-clause-or-other ...) (define-syntax class-info (tr-class-info null null))
(define-values (clauses others) (add-annotations class-info e) ...
(filter-multiple (attribute class-elems.data) (make-locals-table class-info)
clause? (make-class-name-table
non-clause?)) class-info
(define name-dict (extract-names clauses)) #,(attribute forall.type-variables))))))]))
(check-unsupported-features name-dict)
(add-names-to-intdef-context def-ctx name-dict) ;; Add syntax properties and other metadata to class form so that the typechecker
(internal-definition-context-seal def-ctx) ;; can understand the expansion later
(define-values (annotated-methods other-top-level private-fields) (define-syntax (add-annotations stx)
(process-class-contents others name-dict)) (syntax-parse stx
(define annotated-super (tr:class:super-property #'super #t)) #:literal-sets (kernel-literals)
(define ordered-inits (get-all-init-names clauses)) [(_ class-info:id class-exp)
(define optional-inits (get-optional-inits clauses)) (define expanded (local-expand #'class-exp (syntax-local-context) stop-forms))
(ignore (syntax-parse expanded
(tr:class #:literal-sets (kernel-literals)
(quasisyntax/loc stx #:literals (: untyped:super-new untyped:super-make-object
(let-values () untyped:super-instantiate)
#,(internal (make-class-name-table (attribute forall.type-variables) [(begin e ...)
private-fields (quasisyntax/loc #'class-exp
ordered-inits (begin (add-annotations class-info e) ...))]
optional-inits [cls:class-clause
name-dict)) (define info (syntax-local-value #'class-info))
(untyped-class #,annotated-super (define clause-data (attribute cls.data))
#,@(map clause-stx clauses) (match-define (struct clause (stx kind ids types)) clause-data)
;; construct in-body type annotations for clauses ;; to avoid macro taint issues
#,@(apply append (define prop-val (tr:class:clause-ids-property #'cls))
(for/list ([a-clause clauses]) (define clause-data*
(match-define (clause _1 _2 ids types) a-clause) (cond [(and prop-val (init-clause? clause-data))
(for/list ([id ids] [type types] (init-clause stx kind prop-val types
#:when type) (init-clause-optional? clause-data))]
;; FIXME: it might be cleaner to use the type-label-property [prop-val
;; here and use the property to build annotation tables (clause stx kind prop-val types)]
;; in the class type-checker. [else clause-data]))
(tr:class:type-annotation-property (set-tr-class-info-clauses!
(tr:class:top-level-property info
#`(: #,(if (stx-pair? id) (stx-car id) id) (cons clause-data* (tr-class-info-clauses info)))
#,type) (check-unsupported-feature kind #'class-exp)
#t) #'class-exp]
#t)))) ;; if it's a method definition for a declared method, then
#,@(map non-clause-stx annotated-methods) ;; mark it as something to type-check
#,(tr:class:top-level-property [(define-values (id) body)
#`(begin #,@(map non-clause-stx other-top-level)) #:when (method-procedure? #'body)
#t) (tr:class:method-property #'class-exp (syntax-e #'id))]
#,(make-locals-table name-dict private-fields))))))])])) ;; private field definition
[(define-values (id ...) . rst)
(define info (syntax-local-value #'class-info))
(set-tr-class-info-private-fields!
info
(append (syntax->list #'(id ...))
(tr-class-info-private-fields info)))
;; set this property so that the initialization expression for
;; this field is counted as a top-level class expression
(tr:class:top-level-property #'class-exp #t)]
;; special : annotation for augment interface
[(: name:id type:expr #:augment augment-type:expr)
(quasisyntax/loc #'class-exp
(begin
#,(tr:class:top-level-property
(tr:class:type-annotation-property
#'(quote-syntax (:-augment name augment-type)) #t) #t)
#,(tr:class:top-level-property
(tr:class:type-annotation-property
(syntax/loc #'class-exp (: name type)) #t) #t)))]
;; Just process this to add the property
[(: name:id . rst)
(tr:class:top-level-property
(tr:class:type-annotation-property
#'class-exp
#t)
#t)]
;; Identify super-new for the benefit of the type checker
[(~or (untyped:super-new [init-id init-expr] ...)
(untyped:super-make-object init-expr ...)
(untyped:super-instantiate (init-expr ...) [name expr] ...))
(tr:class:top-level-property
(tr:class:super-new-property #'class-exp #t)
#t)]
[_ (tr:class:top-level-property #'class-exp #t)])]))
;; Construct a table in the expansion that lets TR know about the generated
;; identifiers that are used for methods, fields, and such
(define-syntax (make-locals-table stx)
(syntax-parse stx
[(_ class-info:id)
(match-define (tr-class-info clauses private-fields)
(syntax-local-value #'class-info))
(do-make-locals-table (reverse clauses) private-fields)]))
;; Construct a table in the expansion that just records the names of clauses
;; in the class for convenience in later processing
(define-syntax (make-class-name-table stx)
(syntax-parse stx
[(_ class-info:id (type-variable:id ...))
(match-define (tr-class-info clauses private-fields)
(syntax-local-value #'class-info))
(do-make-class-name-table #'(type-variable ...)
(reverse clauses)
private-fields)]))
(begin-for-syntax (begin-for-syntax
;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>> ;; Determine if the given syntax object matches the "method-procedure"
;; -> Listof<Syntax> Listof<Syntax> Listof<Syntax> ;; non-terminal documented for the class macro
;; Process methods and other top-level expressions and definitions (define (method-procedure? stx)
;; that aren't class clauses like `init` or `public` (define stop-list (list #'lambda #'case-lambda
(define (process-class-contents contents name-dict) #'#%plain-lambda #'let-values
(for/fold ([methods '()] #'letrec-values))
[rest-top '()] (define expanded (local-expand stx (syntax-local-context) stop-list))
[private-fields '()]) (define stx*
([content contents]) (syntax-parse expanded
(define stx (non-clause-stx content)) #:literal-sets (kernel-literals)
(syntax-parse stx ;; an extra #%expression is inserted by the local expansion but
#:literals (: define-values super-new ;; won't appear in the actual expansion, so ignore it
super-make-object super-instantiate) [(#%expression e) #'e]
;; if it's a method definition for a declared method, then [_ expanded]))
;; mark it as something to type-check (syntax-parse stx*
[(define-values (id) . rst) #:literal-sets (kernel-literals)
#:when (method-id? #'id name-dict) #:literals (lambda λ)
(values (cons (non-clause (tr:class:method-property stx (syntax-e #'id))) [((~or lambda λ) formals e ...) #t]
methods) [(case-lambda (formals e ...) ...) #t]
rest-top private-fields)] [(#%plain-lambda formals e ...) #t]
;; private field definition [((~or let-values letrec-values) ([(x) m] ...) y:id)
[(define-values (id ...) . rst) (andmap method-procedure? (syntax->list #'(m ...)))]
(values methods [((~or let-values letrec-values) ([(x) m] ...) m1)
(append rest-top (list content)) (and (andmap method-procedure? (syntax->list #'(m ...)))
(append (syntax->list #'(id ...)) (method-procedure? #'m1))]
private-fields))] [_ #f]))
;; special : annotation for augment interface
[(: name:id type:expr #:augment augment-type:expr)
(define new-clause
(non-clause (tr:class:type-annotation-property
#'(quote-syntax (:-augment name augment-type)) #t)))
(define plain-annotation
(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 . rst)
(define plain-annotation
(non-clause (tr:class:type-annotation-property
(syntax/loc stx (: name . rst)) #t)))
(values methods
(append rest-top (list plain-annotation))
private-fields)]
;; Identify super-new for the benefit of the type checker
[(~or (super-new [init-id init-expr] ...)
(super-make-object init-expr ...)
(super-instantiate (init-expr ...) [name expr] ...))
(define new-non-clause
(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 ;; clauses->names : (-> Clause Boolean) Listof<Clause> -> Listof<Id>
;; Check whether the given id is a known method name ;; filter clauses by some property and spit out the names in those clauses
(define (method-id? id name-dict) (define (clauses->names prop clauses [keep-pair? #f])
(memf (λ (n) (free-identifier=? id n)) (apply append
(append (stx-map stx-car (dict-ref name-dict #'public '())) (for/list ([clause (in-list clauses)]
(stx-map stx-car (dict-ref name-dict #'pubment '())) #:when (prop clause))
(stx-map stx-car (dict-ref name-dict #'override '())) (define ids (clause-ids clause))
(stx-map stx-car (dict-ref name-dict #'augment '())) (for/list ([id (in-list ids)])
(dict-ref name-dict #'private '())))) (if (and (not keep-pair?) (stx-pair? id))
(stx-car id)
id)))))
;; get-optional-inits : Listof<Clause> -> Listof<Id> ;; get-optional-inits : Listof<Clause> -> Listof<Id>
;; Get a list of the internal names of optional inits ;; Get a list of the internal names of optional inits
@ -465,49 +282,45 @@
;; get-all-init-names : Listof<Clause> -> Listof<Id> ;; get-all-init-names : Listof<Clause> -> Listof<Id>
;; Get a list of all the (internal) init names in order ;; Get a list of all the (internal) init names in order
(define (get-all-init-names clauses) (define (get-all-init-names clauses)
(flatten (clauses->names init-clause? clauses))
(for/list ([clause clauses]
#:when (init-clause? clause))
(stx-map stx-car (clause-ids clause)))))
;; check-unsupported-features : Dict<Identifier, Names> -> Void ;; check-unsupported-feature : Identifier Syntax -> Void
;; Check if features that are not supported were used and ;; Check if the given identifier corresponds to an unsupported class form
;; raise an error if they are present ;; and emit an error using the given syntax object if it does
(define (check-unsupported-features id-table) (define (check-unsupported-feature id stx)
(for ([form unsupported-forms]) (when (member id unsupported-forms free-identifier=?)
(define entry (dict-ref id-table form null)) (tc-error/stx id "unsupported class clause: ~a" stx)))
(unless (null? entry)
(tc-error/stx
(car entry)
"unsupported class clause: ~a"
(syntax-e form)))))
;; make-class-name-table : Listof<Id> Listof<Id> Listof<Id> ;; do-make-class-name-table : Listof<Id> Listof<Clause> Listof<Id> -> Stx
;; Listof<Id> Dict<Id, Id> -> Stx
;; construct syntax used by the class type-checker as a reliable source ;; 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 ;; for the member names that are in a given class, plus any type
;; variables that are bound ;; variables that are bound
(define (make-class-name-table foralls (define (do-make-class-name-table foralls
private-fields clauses
ordered-inits private-fields)
optional-inits (define (get-names kind)
name-dict) (clauses->names (λ (clause)
#`(class-internal (free-identifier=? (clause-kind clause) kind))
(#:forall #,@foralls) clauses #t))
(#:all-inits #,@ordered-inits) (tr:class:name-table-property
(#:init #,@(dict-ref name-dict #'init '())) (internal
(#:init-field #,@(dict-ref name-dict #'init-field '())) #`(class-internal
(#:init-rest #,@(dict-ref name-dict #'init-rest '())) (#:forall #,@foralls)
(#:optional-init #,@optional-inits) (#:all-inits #,@(get-all-init-names clauses))
(#:field #,@(dict-ref name-dict #'field '())) (#:init #,@(get-names #'untyped:init))
(#:public #,@(dict-ref name-dict #'public '())) (#:init-field #,@(get-names #'untyped:init-field))
(#:override #,@(dict-ref name-dict #'override '())) (#:init-rest #,@(get-names #'untyped:init-rest))
(#:private #,@(dict-ref name-dict #'private '())) (#:optional-init #,@(get-optional-inits clauses))
(#:private-field #,@private-fields) (#:field #,@(get-names #'untyped:field))
(#:inherit #,@(dict-ref name-dict #'inherit '())) (#:public #,@(get-names #'untyped:public))
(#:inherit-field #,@(dict-ref name-dict #'inherit-field '())) (#:override #,@(get-names #'untyped:override))
(#:augment #,@(dict-ref name-dict #'augment '())) (#:private #,@(get-names #'untyped:private))
(#:pubment #,@(dict-ref name-dict #'pubment '())))) (#:private-field #,@private-fields)
(#:inherit #,@(get-names #'untyped:inherit))
(#:inherit-field #,@(get-names #'untyped:inherit-field))
(#:augment #,@(get-names #'untyped:augment))
(#:pubment #,@(get-names #'untyped:pubment))))
#t))
;; This is a neat/horrible trick ;; This is a neat/horrible trick
;; ;;
@ -517,25 +330,22 @@
;; The identifiers inside the lambdas below will expand via ;; The identifiers inside the lambdas below will expand via
;; set!-transformers to the appropriate accessors, which lets ;; set!-transformers to the appropriate accessors, which lets
;; us figure out the accessor identifiers. ;; us figure out the accessor identifiers.
(define (make-locals-table name-dict private-field-names) (define (do-make-locals-table clauses private-field-names)
(define public-names (define (get-names kind)
(stx-map stx-car (dict-ref name-dict #'public '()))) (clauses->names (λ (clause)
(define override-names (free-identifier=? (clause-kind clause) kind))
(stx-map stx-car (dict-ref name-dict #'override '()))) clauses))
(define private-names (dict-ref name-dict #'private '())) (define public-names (get-names #'untyped:public))
(define field-names (define override-names (get-names #'untyped:override))
(append (stx-map stx-car (dict-ref name-dict #'field '())) (define private-names (get-names #'untyped:private))
(stx-map stx-car (dict-ref name-dict #'init-field '())))) (define field-names (append (get-names #'untyped:field)
(define init-names (get-names #'untyped:init-field)))
(stx-map stx-car (dict-ref name-dict #'init '()))) (define init-names (get-names #'untyped:init))
(define init-rest-name (dict-ref name-dict #'init-rest '())) (define init-rest-name (get-names #'untyped:init-rest))
(define inherit-names (define inherit-names (get-names #'untyped:inherit))
(stx-map stx-car (dict-ref name-dict #'inherit '()))) (define inherit-field-names (get-names #'untyped:inherit-field))
(define inherit-field-names (define augment-names (append (get-names #'untyped:pubment)
(stx-map stx-car (dict-ref name-dict #'inherit-field '()))) (get-names #'untyped:augment)))
(define augment-names
(append (stx-map stx-car (dict-ref name-dict #'pubment '()))
(stx-map stx-car (dict-ref name-dict #'augment '()))))
(tr:class:local-table-property (tr:class:local-table-property
#`(let-values ([(#,@public-names) #`(let-values ([(#,@public-names)
(values #,@(map (λ (stx) #`(λ () (#,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx)))
@ -562,10 +372,10 @@
(values #,@(map (λ (stx) #`(λ () (#,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx)))
inherit-names))] inherit-names))]
[(#,@override-names) [(#,@override-names)
(values #,@(map (λ (stx) #`(λ () (#,stx) (super #,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx) (untyped:super #,stx)))
override-names))] override-names))]
[(#,@augment-names) [(#,@augment-names)
(values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx) (untyped:inner #f #,stx)))
augment-names))]) augment-names))])
(void)) (void))
#t))) #t)))

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

@ -73,6 +73,8 @@
(tr:class:type-annotation tr:class:type-annotation) (tr:class:type-annotation tr:class:type-annotation)
(tr:class:super tr:class:super) (tr:class:super tr:class:super)
(tr:class:local-table tr:class:local-table) (tr:class:local-table tr:class:local-table)
(tr:class:name-table tr:class:name-table)
(tr:class:clause-ids tr:class:clause-ids)
(tr:class:method tr:class:method) (tr:class:method tr:class:method)
) )

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

@ -63,24 +63,25 @@
(define-syntax-class internal-class-data (define-syntax-class internal-class-data
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:literals (class-internal values) #:literals (class-internal values)
(pattern (begin (quote-syntax (pattern (let-values ([() (begin (quote-syntax
(class-internal (class-internal
(#:forall type-parameter:id ...) (#:forall type-parameter:id ...)
(#:all-inits all-init-names:id ...) (#:all-inits all-init-names:id ...)
(#:init init-names:name-pair ...) (#:init init-names:name-pair ...)
(#:init-field init-field-names:name-pair ...) (#:init-field init-field-names:name-pair ...)
(#:init-rest (~optional init-rest-name:id)) (#:init-rest (~optional init-rest-name:id))
(#:optional-init optional-names:id ...) (#:optional-init optional-names:id ...)
(#:field field-names:name-pair ...) (#:field field-names:name-pair ...)
(#:public public-names:name-pair ...) (#:public public-names:name-pair ...)
(#:override override-names:name-pair ...) (#:override override-names:name-pair ...)
(#:private privates:id ...) (#:private privates:id ...)
(#:private-field private-fields:id ...) (#:private-field private-fields:id ...)
(#:inherit inherit-names:name-pair ...) (#:inherit inherit-names:name-pair ...)
(#:inherit-field inherit-field-names:name-pair ...) (#:inherit-field inherit-field-names:name-pair ...)
(#:augment augment-names:name-pair ...) (#:augment augment-names:name-pair ...)
(#:pubment pubment-names:name-pair ...))) (#:pubment pubment-names:name-pair ...)))
(#%plain-app values)) (#%plain-app values))])
_)
#:with type-parameters #'(type-parameter ...) #:with type-parameters #'(type-parameter ...)
#:with all-init-internals #'(all-init-names ...) #:with all-init-internals #'(all-init-names ...)
#:with init-internals #'(init-names.internal ...) #:with init-internals #'(init-names.internal ...)
@ -153,38 +154,19 @@
(define-syntax-class class-expansion (define-syntax-class class-expansion
#:literals (let-values letrec-syntaxes+values #%plain-app quote) #:literals (let-values letrec-syntaxes+values #%plain-app quote)
#:attributes (superclass-expr #:attributes (superclass-expr
type-parameters
all-init-internals
init-internals init-externals
init-field-internals init-field-externals
init-rest-name
optional-inits
field-internals field-externals
public-internals public-externals
override-internals override-externals
inherit-internals inherit-externals
inherit-field-internals inherit-field-externals
augment-internals augment-externals
pubment-internals pubment-externals
private-names private-field-names
make-methods make-methods
initializer-body initializer-body
initializer-self-id initializer-self-id
initializer-args-id) initializer-args-id)
(pattern (let-values () (pattern (#%plain-app
(letrec-syntaxes+values compose-class:id
() name:expr
((() ;; residual class: data superclass-expr:expr
:internal-class-data)) interface-expr:expr
(#%plain-app internal:expr ...
compose-class:id (~and make-methods :make-methods-class)
name:expr (quote :boolean)
superclass-expr:expr (quote #f))))
interface-expr:expr
internal:expr ...
(~and make-methods :make-methods-class)
(quote :boolean)
(quote #f))))))
;; This is similar to `type-declaration` from "internal-forms.rkt", but ;; This is similar to `type-declaration` from "internal-forms.rkt", but
;; the expansion is slightly different in a class so we use this instead. ;; the expansion is slightly different in a class so we use this instead.
@ -234,89 +216,93 @@
;; FIXME: maybe should check the property on this expression ;; FIXME: maybe should check the property on this expression
;; as a sanity check too ;; as a sanity check too
(define super-type (tc-expr #'cls.superclass-expr)) (define super-type (tc-expr #'cls.superclass-expr))
;; Save parse attributes to pass through to helper functions (define class-name-table
(define type-parameters (syntax->datum #'cls.type-parameters)) (car (trawl-for-property #'cls.make-methods tr:class:name-table-property)))
(define fresh-parameters (map gensym type-parameters)) (syntax-parse class-name-table
(define parse-info [tbl:internal-class-data
(hash 'type-parameters type-parameters ;; Save parse attributes to pass through to helper functions
'fresh-parameters fresh-parameters (define type-parameters (syntax->datum #'tbl.type-parameters))
'superclass-expr #'cls.superclass-expr (define fresh-parameters (map gensym type-parameters))
'make-methods #'cls.make-methods (define parse-info
'initializer-self-id #'cls.initializer-self-id (hash 'type-parameters type-parameters
'initializer-args-id #'cls.initializer-args-id 'fresh-parameters fresh-parameters
'initializer-body #'cls.initializer-body 'superclass-expr #'cls.superclass-expr
'optional-inits (syntax->datum #'cls.optional-inits) 'make-methods #'cls.make-methods
'only-init-internals (syntax->datum #'cls.init-internals) 'initializer-self-id #'cls.initializer-self-id
'only-init-names (syntax->datum #'cls.init-externals) 'initializer-args-id #'cls.initializer-args-id
;; the order of these names reflect the order in the class, 'initializer-body #'cls.initializer-body
;; so use this list when retaining the order is important 'optional-inits (syntax->datum #'tbl.optional-inits)
'init-internals (syntax->datum #'cls.all-init-internals) 'only-init-internals (syntax->datum #'tbl.init-internals)
'init-rest-name (and (attribute cls.init-rest-name) 'only-init-names (syntax->datum #'tbl.init-externals)
(syntax-e (attribute cls.init-rest-name))) ;; the order of these names reflect the order in the class,
'public-internals (syntax->datum #'cls.public-internals) ;; so use this list when retaining the order is important
'override-internals (syntax->datum #'cls.override-internals) 'init-internals (syntax->datum #'tbl.all-init-internals)
'pubment-internals (syntax->datum #'cls.pubment-internals) 'init-rest-name (and (attribute tbl.init-rest-name)
'augment-internals (syntax->datum #'cls.augment-internals) (syntax-e (attribute tbl.init-rest-name)))
'method-internals 'public-internals (syntax->datum #'tbl.public-internals)
(set-union (syntax->datum #'cls.public-internals) 'override-internals (syntax->datum #'tbl.override-internals)
(syntax->datum #'cls.override-internals)) 'pubment-internals (syntax->datum #'tbl.pubment-internals)
'field-internals 'augment-internals (syntax->datum #'tbl.augment-internals)
(set-union (syntax->datum #'cls.field-internals) 'method-internals
(syntax->datum #'cls.init-field-internals)) (set-union (syntax->datum #'tbl.public-internals)
'inherit-internals (syntax->datum #'tbl.override-internals))
(syntax->datum #'cls.inherit-internals) 'field-internals
'inherit-field-internals (set-union (syntax->datum #'tbl.field-internals)
(syntax->datum #'cls.inherit-field-internals) (syntax->datum #'tbl.init-field-internals))
'init-names 'inherit-internals
(set-union (syntax->datum #'cls.init-externals) (syntax->datum #'tbl.inherit-internals)
(syntax->datum #'cls.init-field-externals)) 'inherit-field-internals
'field-names (syntax->datum #'tbl.inherit-field-internals)
(set-union (syntax->datum #'cls.field-externals) 'init-names
(syntax->datum #'cls.init-field-externals)) (set-union (syntax->datum #'tbl.init-externals)
'public-names (syntax->datum #'cls.public-externals) (syntax->datum #'tbl.init-field-externals))
'override-names (syntax->datum #'cls.override-externals) 'field-names
'pubment-names (syntax->datum #'cls.pubment-externals) (set-union (syntax->datum #'tbl.field-externals)
'augment-names (syntax->datum #'cls.augment-externals) (syntax->datum #'tbl.init-field-externals))
'inherit-names (syntax->datum #'cls.inherit-externals) 'public-names (syntax->datum #'tbl.public-externals)
'inherit-field-names 'override-names (syntax->datum #'tbl.override-externals)
(syntax->datum #'cls.inherit-field-externals) 'pubment-names (syntax->datum #'tbl.pubment-externals)
'private-names (syntax->datum #'cls.private-names) 'augment-names (syntax->datum #'tbl.augment-externals)
'private-fields (syntax->datum #'cls.private-field-names) 'inherit-names (syntax->datum #'tbl.inherit-externals)
'overridable-names 'inherit-field-names
(set-union (syntax->datum #'cls.public-externals) (syntax->datum #'tbl.inherit-field-externals)
(syntax->datum #'cls.override-externals)) 'private-names (syntax->datum #'tbl.private-names)
'augmentable-names 'private-fields (syntax->datum #'tbl.private-field-names)
(set-union (syntax->datum #'cls.pubment-externals) 'overridable-names
(syntax->datum #'cls.augment-externals)) (set-union (syntax->datum #'tbl.public-externals)
'method-names (syntax->datum #'tbl.override-externals))
(set-union (syntax->datum #'cls.public-externals) 'augmentable-names
(syntax->datum #'cls.override-externals) (set-union (syntax->datum #'tbl.pubment-externals)
(syntax->datum #'cls.augment-externals) (syntax->datum #'tbl.augment-externals))
(syntax->datum #'cls.pubment-externals)) 'method-names
'all-internal (set-union (syntax->datum #'tbl.public-externals)
(append (syntax->datum #'cls.init-internals) (syntax->datum #'tbl.override-externals)
(syntax->datum #'cls.init-field-internals) (syntax->datum #'tbl.augment-externals)
(syntax->datum #'cls.field-internals) (syntax->datum #'tbl.pubment-externals))
(syntax->datum #'cls.public-internals) 'all-internal
(syntax->datum #'cls.override-internals) (append (syntax->datum #'tbl.init-internals)
(syntax->datum #'cls.inherit-internals) (syntax->datum #'tbl.init-field-internals)
(syntax->datum #'cls.inherit-field-internals) (syntax->datum #'tbl.field-internals)
(syntax->datum #'cls.pubment-internals) (syntax->datum #'tbl.public-internals)
(syntax->datum #'cls.augment-internals)) (syntax->datum #'tbl.override-internals)
'all-external (syntax->datum #'tbl.inherit-internals)
(append (syntax->datum #'cls.init-externals) (syntax->datum #'tbl.inherit-field-internals)
(syntax->datum #'cls.init-field-externals) (syntax->datum #'tbl.pubment-internals)
(syntax->datum #'cls.field-externals) (syntax->datum #'tbl.augment-internals))
(syntax->datum #'cls.public-externals) 'all-external
(syntax->datum #'cls.override-externals) (append (syntax->datum #'tbl.init-externals)
(syntax->datum #'cls.inherit-externals) (syntax->datum #'tbl.init-field-externals)
(syntax->datum #'cls.inherit-field-externals) (syntax->datum #'tbl.field-externals)
(syntax->datum #'cls.pubment-externals) (syntax->datum #'tbl.public-externals)
(syntax->datum #'cls.augment-externals)))) (syntax->datum #'tbl.override-externals)
(with-timing (syntax->datum #'tbl.inherit-externals)
(do-timestamp (format "methods ~a" (dict-ref parse-info 'method-names))) (syntax->datum #'tbl.inherit-field-externals)
(extend-tvars/new type-parameters fresh-parameters (syntax->datum #'tbl.pubment-externals)
(do-check expected super-type parse-info)))])) (syntax->datum #'tbl.augment-externals))))
(with-timing
(do-timestamp (format "methods ~a" (dict-ref parse-info 'method-names)))
(extend-tvars/new type-parameters fresh-parameters
(do-check expected super-type parse-info)))])]))
;; do-check : Type Type Dict -> Type ;; do-check : Type Type Dict -> Type
;; The actual type-checking ;; The actual type-checking

48
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt
View File

@ -6,7 +6,9 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(rep type-rep rep-utils) (rep type-rep rep-utils)
(types resolve) (types resolve)
(except-in racket/class private) (prefix-in untyped: racket/class)
(except-in (base-env class-clauses)
private)
racket/dict racket/dict
racket/list racket/list
racket/match racket/match
@ -14,7 +16,7 @@
syntax/stx syntax/stx
(only-in unstable/list check-duplicate) (only-in unstable/list check-duplicate)
(only-in unstable/sequence in-syntax) (only-in unstable/sequence in-syntax)
(for-template racket/class)) (for-template (base-env class-clauses)))
(provide Class: (provide Class:
row-constraints row-constraints
@ -25,6 +27,11 @@
object-type-clauses object-type-clauses
class-type-clauses) class-type-clauses)
(define-literal-set class-type-literals
(init init-field init-rest field augment
untyped:init untyped:init-field untyped:init-rest
untyped:field untyped:augment))
;; Data definitions ;; Data definitions
;; ;;
;; A RowConstraint is a ;; A RowConstraint is a
@ -37,11 +44,11 @@
;; Syntax classes for rows ;; Syntax classes for rows
(define-splicing-syntax-class row-constraints (define-splicing-syntax-class row-constraints
#:literals (init init-field field augment) #:literal-sets (class-type-literals)
(pattern (~seq (~or (init iname:id ...) (pattern (~seq (~or ((~or init untyped:init) iname:id ...)
(init-field ifname:id ...) ((~or init-field untyped:init-field) ifname:id ...)
(field fname:id ...) ((~or field untyped:field) fname:id ...)
(augment aname:id ...) ((~or augment untyped:augment) aname:id ...)
mname:id) mname:id)
...) ...)
#:attr init-names (flatten/datum #'((iname ...) ...)) #:attr init-names (flatten/datum #'((iname ...) ...))
@ -92,8 +99,9 @@
(define-splicing-syntax-class (row-clauses parse-type) (define-splicing-syntax-class (row-clauses parse-type)
#:description "Row type clause" #:description "Row type clause"
#:attributes (row) #:attributes (row)
#:literals (init-rest) #:literal-sets (class-type-literals)
(pattern (~seq (~or (~optional (init-rest init-rest-type:expr)) (pattern (~seq (~or (~optional ((~or init-rest untyped:init-rest)
init-rest-type:expr))
(~var clause (type-clause parse-type))) (~var clause (type-clause parse-type)))
...) ...)
#:attr inits (apply append (attribute clause.init-entries)) #:attr inits (apply append (attribute clause.init-entries))
@ -180,8 +188,9 @@
(define-splicing-syntax-class object-type-clauses (define-splicing-syntax-class object-type-clauses
#:description "Object type clause" #:description "Object type clause"
#:attributes (field-names field-types method-names method-types) #:attributes (field-names field-types method-names method-types)
#:literals (field) #:literal-sets (class-type-literals)
(pattern (~seq (~or (field field-clause:field-or-method-type ...) (pattern (~seq (~or ((~or field untyped:field)
field-clause:field-or-method-type ...)
method-clause:field-or-method-type) method-clause:field-or-method-type)
...) ...)
#:with field-names (flatten-class-clause #'((field-clause.label ...) ...)) #:with field-names (flatten-class-clause #'((field-clause.label ...) ...))
@ -204,10 +213,11 @@
#:description "Class type clause" #:description "Class type clause"
#:attributes (row-var extends-types #:attributes (row-var extends-types
inits fields methods augments init-rest) inits fields methods augments init-rest)
#:literals (init-rest) #:literal-sets (class-type-literals)
(pattern (~seq (~or (~optional (~seq #:row-var row-var:id)) (pattern (~seq (~or (~optional (~seq #:row-var row-var:id))
(~seq #:implements extends-type:id) (~seq #:implements extends-type:id)
(~optional (init-rest init-rest-type:expr)) (~optional ((~or init-rest untyped:init-rest)
init-rest-type:expr))
(~var clause (type-clause parse-type))) (~var clause (type-clause parse-type)))
...) ...)
#:attr inits (apply append (attribute clause.init-entries)) #:attr inits (apply append (attribute clause.init-entries))
@ -250,8 +260,8 @@
(define-syntax-class (type-clause parse-type) (define-syntax-class (type-clause parse-type)
#:attributes (init-entries field-entries #:attributes (init-entries field-entries
method-entries augment-entries) method-entries augment-entries)
#:literals (init init-field field augment) #:literal-sets (class-type-literals)
(pattern (init init-clause:init-type ...) (pattern ((~or init untyped:init) init-clause:init-type ...)
#:attr init-entries #:attr init-entries
(make-init-entries (make-init-entries
#'(init-clause.label ...) #'(init-clause.label ...)
@ -261,7 +271,8 @@
#:attr field-entries null #:attr field-entries null
#:attr method-entries null #:attr method-entries null
#:attr augment-entries null) #:attr augment-entries null)
(pattern (init-field init-field-clause:init-type ...) (pattern ((~or init-field untyped:init-field)
init-field-clause:init-type ...)
#:attr init-entries #:attr init-entries
(make-init-entries (make-init-entries
#'(init-field-clause.label ...) #'(init-field-clause.label ...)
@ -275,7 +286,7 @@
parse-type) parse-type)
#:attr method-entries null #:attr method-entries null
#:attr augment-entries null) #:attr augment-entries null)
(pattern (field field-clause:field-or-method-type ...) (pattern ((~or field untyped:field) field-clause:field-or-method-type ...)
#:attr init-entries null #:attr init-entries null
#:attr field-entries #:attr field-entries
(make-field/augment-entries (make-field/augment-entries
@ -284,7 +295,8 @@
parse-type) parse-type)
#:attr method-entries null #:attr method-entries null
#:attr augment-entries null) #:attr augment-entries null)
(pattern (augment augment-clause:field-or-method-type ...) (pattern ((~or augment untyped:augment)
augment-clause:field-or-method-type ...)
#:attr init-entries null #:attr init-entries null
#:attr field-entries null #:attr field-entries null
#:attr method-entries null #:attr method-entries null

17
pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/class.rkt
View File

@ -1,18 +1,9 @@
#lang racket/base #lang racket/base
(require (except-in racket/class (require racket/require
class (subtract-in racket/class
define/public typed-racket/base-env/class-prims)
define/override
define/pubment
define/augment
define/private)
typed-racket/base-env/class-prims) typed-racket/base-env/class-prims)
(provide class (provide (all-from-out typed-racket/base-env/class-prims)
define/public
define/override
define/pubment
define/augment
define/private
(all-from-out racket/class)) (all-from-out racket/class))

2
pkgs/typed-racket-pkgs/typed-racket-more/typed/mred/mred.rkt
View File

@ -1,6 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/class (require typed/racket/class
typed/private/utils) typed/private/utils)
(provide Frame% (provide Frame%

2
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/send.rkt
View File

@ -12,7 +12,7 @@
(provide fish%)) (provide fish%))
(module fish-client typed/racket/base (module fish-client typed/racket/base
(require racket/class) (require typed/racket/class)
(require/typed (submod ".." fish) [fish% Fish%]) (require/typed (submod ".." fish) [fish% Fish%])
(define-type-alias Fish% (Class (init [weight Real]) (define-type-alias Fish% (Class (init [weight Real])

8
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
View File

@ -17,9 +17,7 @@
;; see typecheck-tests.rkt for rationale on imports ;; see typecheck-tests.rkt for rationale on imports
(require rackunit (require rackunit
(except-in racket/class typed/racket/class
class define/public define/override
define/pubment define/augment define/private)
(except-in typed-racket/utils/utils private) (except-in typed-racket/utils/utils private)
(except-in (base-env extra-procs prims class-prims (except-in (base-env extra-procs prims class-prims
base-types base-types-extra) base-types base-types-extra)
@ -1325,8 +1323,8 @@
(super-new) (super-new)
(: x String) (: x String)
(field [x : Symbol 0])) (field [x : Symbol 0]))
#:ret (ret (-class #:field ([x -Symbol]))) #:ret (ret (-class #:field ([x -String])))
#:msg #rx"duplicate type annotation.*new type: String"] #:msg #rx"duplicate type annotation.*new type: Symbol"]
;; fails, expected type and annotation don't match ;; fails, expected type and annotation don't match
[tc-err (let () [tc-err (let ()
(: c% (Class (field [x String]))) (: c% (Class (field [x String])))

23
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-util-tests.rkt
View File

@ -10,7 +10,10 @@
syntax/parse syntax/parse
syntax/stx syntax/stx
;; phase-shift down for use in tests below ;; phase-shift down for use in tests below
(for-template (submod typed-racket/base-env/class-prims internal))) (for-template (submod typed-racket/base-env/class-prims internal)
(submod typed-racket/base-env/class-clauses internal)
(only-in typed-racket/base-env/class-clauses
class-clause clause init-clause)))
(provide tests) (provide tests)
(gen-test-main) (gen-test-main)
@ -44,22 +47,6 @@
(check-true (syntax-parses? #'([x y]) init-decl)) (check-true (syntax-parses? #'([x y]) init-decl))
(check-true (syntax-parses? #'(x 0) init-decl)) (check-true (syntax-parses? #'(x 0) init-decl))
(check-true (syntax-parses? #'([x y] 0) init-decl)) (check-true (syntax-parses? #'([x y] 0) init-decl))
(check-true (syntax-parses? #'(init x y z) class-clause))
(check-true (syntax-parses? #'(public f g h) class-clause))
(check-true (syntax-parses? #'(public f) class-clause-or-other))
(check-equal?/id
(extract-names (list (clause #'(init x y z)
#'init
(list #'(x x) #'(y y) #'(z z))
(list #f #f #f))
(clause #'(public f g h)
#'public
(list #'(f f) #'(g g) #'(h h))
(list #f #f #f))))
(make-immutable-free-id-table
(hash #'public (list #'(f f) #'(g g) #'(h h))
#'init (list #'(x x) #'(y y) #'(z z))))
(check-equal?/id (check-equal?/id
(get-optional-inits (get-optional-inits
@ -67,5 +54,5 @@
(list #f) (list #t)) (list #f) (list #t))
(init-clause #'(init [(a b)]) #'init #'([a b]) (init-clause #'(init [(a b)]) #'init #'([a b])
(list #f) (list #f)))) (list #f) (list #f))))
(list #'x))))) (list #'x))))

9
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
View File

@ -19,7 +19,8 @@
(base-env base-types base-types-extra colon) (base-env base-types base-types-extra colon)
;; needed for parsing case-lambda/case-> types ;; needed for parsing case-lambda/case-> types
(only-in (base-env case-lambda) case-lambda) (only-in (base-env case-lambda) case-lambda)
(only-in racket/class init init-field field augment) (prefix-in un: (only-in racket/class init init-field field augment))
(only-in typed/racket/class init init-field field augment)
rackunit) rackunit)
@ -261,6 +262,8 @@
[(Class) (-class)] [(Class) (-class)]
[(Class (init [x Number] [y Number])) [(Class (init [x Number] [y Number]))
(-class #:init ([x -Number #f] [y -Number #f]))] (-class #:init ([x -Number #f] [y -Number #f]))]
[(Class (un:init [x Number] [y Number]))
(-class #:init ([x -Number #f] [y -Number #f]))]
[(Class (init [x Number] [y Number #:optional])) [(Class (init [x Number] [y Number #:optional]))
(-class #:init ([x -Number #f] [y -Number #t]))] (-class #:init ([x -Number #f] [y -Number #t]))]
[(Class (init [x Number]) (init-field [y Number])) [(Class (init [x Number]) (init-field [y Number]))
@ -271,8 +274,12 @@
(-class #:init ([x -Number #f]) #:method ([m (t:-> N N)]))] (-class #:init ([x -Number #f]) #:method ([m (t:-> N N)]))]
[(Class [m (Number -> Number)] (field [x Number])) [(Class [m (Number -> Number)] (field [x Number]))
(-class #:field ([x -Number]) #:method ([m (t:-> N N)]))] (-class #:field ([x -Number]) #:method ([m (t:-> N N)]))]
[(Class [m (Number -> Number)] (un:field [x Number]))
(-class #:field ([x -Number]) #:method ([m (t:-> N N)]))]
[(Class (augment [m (Number -> Number)])) [(Class (augment [m (Number -> Number)]))
(-class #:augment ([m (t:-> N N)]))] (-class #:augment ([m (t:-> N N)]))]
[(Class (un:augment [m (Number -> Number)]))
(-class #:augment ([m (t:-> N N)]))]
[(Class (augment [m (Number -> Number)]) (field [x Number])) [(Class (augment [m (Number -> Number)]) (field [x Number]))
(-class #:augment ([m (t:-> N N)]) #:field ([x -Number]))] (-class #:augment ([m (t:-> N N)]) #:field ([x -Number]))]
[(Class (augment [m (-> Number)]) [m (-> Number)]) [(Class (augment [m (-> Number)]) [m (-> Number)])