Rewrite TR class form to preserve abstractions
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
parent
d17fca3838
commit
725cb99f4a
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require typed/mred/mred
|
||||
typed/framework/framework
|
||||
racket/class
|
||||
typed/racket/class
|
||||
string-constants)
|
||||
|
||||
(require/typed framework
|
||||
|
|
|
|||
|
|
@ -224,6 +224,23 @@ additional provides all other bindings from @racketmodname[racket/class].
|
|||
@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}
|
||||
|
||||
@defform[#:literals (init init-field init-rest field augment)
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
|
@ -2,13 +2,8 @@
|
|||
|
||||
;; This module provides TR primitives for classes and objects
|
||||
|
||||
(require (rename-in (except-in racket/class
|
||||
define/public
|
||||
define/override
|
||||
define/pubment
|
||||
define/augment
|
||||
define/private)
|
||||
[class untyped-class])
|
||||
(require (prefix-in untyped: racket/class)
|
||||
"class-clauses.rkt"
|
||||
"colon.rkt"
|
||||
"../typecheck/internal-forms.rkt"
|
||||
"../private/class-literals.rkt"
|
||||
|
|
@ -16,21 +11,12 @@
|
|||
(for-syntax
|
||||
racket/base
|
||||
racket/class
|
||||
racket/dict
|
||||
racket/list
|
||||
racket/match
|
||||
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/parse
|
||||
syntax/stx
|
||||
unstable/list
|
||||
"annotate-classes.rkt"
|
||||
"../private/syntax-properties.rkt"
|
||||
"../utils/tc-utils.rkt"))
|
||||
|
|
@ -42,9 +28,21 @@
|
|||
define/override
|
||||
define/pubment
|
||||
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) ...))
|
||||
(begin (define-syntax (?id stx)
|
||||
(syntax-parse stx
|
||||
|
|
@ -62,394 +60,213 @@
|
|||
[define/private private]))
|
||||
|
||||
(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
|
||||
(define unsupported-forms
|
||||
(list (quote-syntax augride)
|
||||
(list (quote-syntax untyped:augride)
|
||||
;; FIXME: see if override contracts are enough
|
||||
;; to keep these at bay or whether they
|
||||
;; need to be handled
|
||||
(quote-syntax public-final)
|
||||
(quote-syntax override-final)
|
||||
(quote-syntax augment-final)
|
||||
(quote-syntax overment)
|
||||
(quote-syntax abstract)
|
||||
(quote-syntax rename-super)
|
||||
(quote-syntax inherit/super)
|
||||
(quote-syntax inherit/inner)
|
||||
(quote-syntax rename-inner)))
|
||||
(quote-syntax untyped:public-final)
|
||||
(quote-syntax untyped:override-final)
|
||||
(quote-syntax untyped:augment-final)
|
||||
(quote-syntax untyped:overment)
|
||||
(quote-syntax untyped:abstract)
|
||||
(quote-syntax untyped:rename-super)
|
||||
(quote-syntax untyped:inherit/super)
|
||||
(quote-syntax untyped:inherit/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
|
||||
(append (kernel-form-identifier-list)
|
||||
unsupported-forms
|
||||
(list
|
||||
(quote-syntax :)
|
||||
(quote-syntax #%app)
|
||||
(quote-syntax lambda)
|
||||
(quote-syntax init)
|
||||
(quote-syntax field)
|
||||
(quote-syntax init-field)
|
||||
(quote-syntax init-rest)
|
||||
(quote-syntax inherit-field)
|
||||
(quote-syntax private)
|
||||
(quote-syntax public)
|
||||
(quote-syntax override)
|
||||
(quote-syntax pubment)
|
||||
(quote-syntax augment)
|
||||
(quote-syntax inherit)
|
||||
(quote-syntax super)
|
||||
(quote-syntax inner)
|
||||
(quote-syntax this)
|
||||
(quote-syntax this%)
|
||||
(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
|
||||
(:))
|
||||
(quote-syntax untyped:init)
|
||||
(quote-syntax untyped:field)
|
||||
(quote-syntax untyped:init-field)
|
||||
(quote-syntax untyped:init-rest)
|
||||
(quote-syntax untyped:inherit-field)
|
||||
(quote-syntax untyped:private)
|
||||
(quote-syntax untyped:public)
|
||||
(quote-syntax untyped:override)
|
||||
(quote-syntax untyped:pubment)
|
||||
(quote-syntax untyped:augment)
|
||||
(quote-syntax untyped:inherit)
|
||||
(quote-syntax untyped:super)
|
||||
(quote-syntax untyped:inner)
|
||||
(quote-syntax untyped:super-new)
|
||||
(quote-syntax untyped:super-instantiate)
|
||||
(quote-syntax untyped:super-make-object)
|
||||
(quote-syntax untyped:inspect))))
|
||||
|
||||
(define-splicing-syntax-class maybe-type-parameter
|
||||
(pattern (~seq (~or #:∀ #:forall) (type-variable:id ...))
|
||||
#:attr type-variables #'(type-variable ...))
|
||||
(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
|
||||
#: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)))
|
||||
;; export some syntax-time definitions for testing purposes
|
||||
(module+ internal
|
||||
(provide (for-syntax get-optional-inits)))
|
||||
|
||||
(define-syntax (class stx)
|
||||
(syntax-parse stx
|
||||
[(_ super forall:maybe-type-parameter e ...)
|
||||
(define class-ctx (generate-class-expand-context))
|
||||
(define def-ctx (syntax-local-make-definition-context))
|
||||
(define expanded-stx
|
||||
(expand-expressions (syntax->list #'(e ...)) class-ctx def-ctx))
|
||||
(syntax-parse expanded-stx
|
||||
[(class-elems:class-clause-or-other ...)
|
||||
(define-values (clauses others)
|
||||
(filter-multiple (attribute class-elems.data)
|
||||
clause?
|
||||
non-clause?))
|
||||
(define name-dict (extract-names clauses))
|
||||
(check-unsupported-features name-dict)
|
||||
(add-names-to-intdef-context def-ctx name-dict)
|
||||
(internal-definition-context-seal def-ctx)
|
||||
(define-values (annotated-methods other-top-level private-fields)
|
||||
(process-class-contents others name-dict))
|
||||
(define annotated-super (tr:class:super-property #'super #t))
|
||||
(define ordered-inits (get-all-init-names clauses))
|
||||
(define optional-inits (get-optional-inits clauses))
|
||||
(define/with-syntax class-info (generate-temporary))
|
||||
(ignore
|
||||
(tr:class
|
||||
(quasisyntax/loc stx
|
||||
(let-values ()
|
||||
#,(internal (make-class-name-table (attribute forall.type-variables)
|
||||
private-fields
|
||||
ordered-inits
|
||||
optional-inits
|
||||
name-dict))
|
||||
(untyped-class #,annotated-super
|
||||
#,@(map clause-stx clauses)
|
||||
;; construct in-body type annotations for clauses
|
||||
#,@(apply append
|
||||
(for/list ([a-clause clauses])
|
||||
(match-define (clause _1 _2 ids types) a-clause)
|
||||
(for/list ([id ids] [type types]
|
||||
#:when type)
|
||||
;; 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)
|
||||
#t)
|
||||
#t))))
|
||||
#,@(map non-clause-stx annotated-methods)
|
||||
#,(tr:class:top-level-property
|
||||
#`(begin #,@(map non-clause-stx other-top-level))
|
||||
#t)
|
||||
#,(make-locals-table name-dict private-fields))))))])]))
|
||||
(untyped:class #,(tr:class:super-property #'super #t)
|
||||
(define-syntax class-info (tr-class-info null null))
|
||||
(add-annotations class-info e) ...
|
||||
(make-locals-table class-info)
|
||||
(make-class-name-table
|
||||
class-info
|
||||
#,(attribute forall.type-variables))))))]))
|
||||
|
||||
(begin-for-syntax
|
||||
;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>>
|
||||
;; -> Listof<Syntax> Listof<Syntax> Listof<Syntax>
|
||||
;; Process methods and other top-level expressions and definitions
|
||||
;; that aren't class clauses like `init` or `public`
|
||||
(define (process-class-contents contents name-dict)
|
||||
(for/fold ([methods '()]
|
||||
[rest-top '()]
|
||||
[private-fields '()])
|
||||
([content contents])
|
||||
(define stx (non-clause-stx content))
|
||||
;; Add syntax properties and other metadata to class form so that the typechecker
|
||||
;; can understand the expansion later
|
||||
(define-syntax (add-annotations stx)
|
||||
(syntax-parse stx
|
||||
#:literals (: define-values super-new
|
||||
super-make-object super-instantiate)
|
||||
#:literal-sets (kernel-literals)
|
||||
[(_ class-info:id class-exp)
|
||||
(define expanded (local-expand #'class-exp (syntax-local-context) stop-forms))
|
||||
(syntax-parse expanded
|
||||
#:literal-sets (kernel-literals)
|
||||
#:literals (: untyped:super-new untyped:super-make-object
|
||||
untyped:super-instantiate)
|
||||
[(begin e ...)
|
||||
(quasisyntax/loc #'class-exp
|
||||
(begin (add-annotations class-info e) ...))]
|
||||
[cls:class-clause
|
||||
(define info (syntax-local-value #'class-info))
|
||||
(define clause-data (attribute cls.data))
|
||||
(match-define (struct clause (stx kind ids types)) clause-data)
|
||||
;; to avoid macro taint issues
|
||||
(define prop-val (tr:class:clause-ids-property #'cls))
|
||||
(define clause-data*
|
||||
(cond [(and prop-val (init-clause? clause-data))
|
||||
(init-clause stx kind prop-val types
|
||||
(init-clause-optional? clause-data))]
|
||||
[prop-val
|
||||
(clause stx kind prop-val types)]
|
||||
[else clause-data]))
|
||||
(set-tr-class-info-clauses!
|
||||
info
|
||||
(cons clause-data* (tr-class-info-clauses info)))
|
||||
(check-unsupported-feature kind #'class-exp)
|
||||
#'class-exp]
|
||||
;; if it's a method definition for a declared method, then
|
||||
;; mark it as something to type-check
|
||||
[(define-values (id) . rst)
|
||||
#:when (method-id? #'id name-dict)
|
||||
(values (cons (non-clause (tr:class:method-property stx (syntax-e #'id)))
|
||||
methods)
|
||||
rest-top private-fields)]
|
||||
[(define-values (id) body)
|
||||
#:when (method-procedure? #'body)
|
||||
(tr:class:method-property #'class-exp (syntax-e #'id))]
|
||||
;; private field definition
|
||||
[(define-values (id ...) . rst)
|
||||
(values methods
|
||||
(append rest-top (list content))
|
||||
(define info (syntax-local-value #'class-info))
|
||||
(set-tr-class-info-private-fields!
|
||||
info
|
||||
(append (syntax->list #'(id ...))
|
||||
private-fields))]
|
||||
(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)
|
||||
(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)]
|
||||
(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)
|
||||
(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)]
|
||||
(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 (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)])))
|
||||
[(~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)])]))
|
||||
|
||||
;; 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 '()))))
|
||||
;; 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
|
||||
;; Determine if the given syntax object matches the "method-procedure"
|
||||
;; non-terminal documented for the class macro
|
||||
(define (method-procedure? stx)
|
||||
(define stop-list (list #'lambda #'case-lambda
|
||||
#'#%plain-lambda #'let-values
|
||||
#'letrec-values))
|
||||
(define expanded (local-expand stx (syntax-local-context) stop-list))
|
||||
(define stx*
|
||||
(syntax-parse expanded
|
||||
#:literal-sets (kernel-literals)
|
||||
;; an extra #%expression is inserted by the local expansion but
|
||||
;; won't appear in the actual expansion, so ignore it
|
||||
[(#%expression e) #'e]
|
||||
[_ expanded]))
|
||||
(syntax-parse stx*
|
||||
#:literal-sets (kernel-literals)
|
||||
#:literals (lambda λ)
|
||||
[((~or lambda λ) formals e ...) #t]
|
||||
[(case-lambda (formals e ...) ...) #t]
|
||||
[(#%plain-lambda formals e ...) #t]
|
||||
[((~or let-values letrec-values) ([(x) m] ...) y:id)
|
||||
(andmap method-procedure? (syntax->list #'(m ...)))]
|
||||
[((~or let-values letrec-values) ([(x) m] ...) m1)
|
||||
(and (andmap method-procedure? (syntax->list #'(m ...)))
|
||||
(method-procedure? #'m1))]
|
||||
[_ #f]))
|
||||
|
||||
;; clauses->names : (-> Clause Boolean) Listof<Clause> -> Listof<Id>
|
||||
;; filter clauses by some property and spit out the names in those clauses
|
||||
(define (clauses->names prop clauses [keep-pair? #f])
|
||||
(apply append
|
||||
(for/list ([clause (in-list clauses)]
|
||||
#:when (prop clause))
|
||||
(define ids (clause-ids clause))
|
||||
(for/list ([id (in-list ids)])
|
||||
(if (and (not keep-pair?) (stx-pair? id))
|
||||
(stx-car id)
|
||||
id)))))
|
||||
|
||||
;; get-optional-inits : Listof<Clause> -> Listof<Id>
|
||||
;; Get a list of the internal names of optional inits
|
||||
|
|
@ -465,49 +282,45 @@
|
|||
;; get-all-init-names : Listof<Clause> -> Listof<Id>
|
||||
;; Get a list of all the (internal) init names in order
|
||||
(define (get-all-init-names clauses)
|
||||
(flatten
|
||||
(for/list ([clause clauses]
|
||||
#:when (init-clause? clause))
|
||||
(stx-map stx-car (clause-ids clause)))))
|
||||
(clauses->names init-clause? clauses))
|
||||
|
||||
;; check-unsupported-features : Dict<Identifier, Names> -> Void
|
||||
;; Check if features that are not supported were used and
|
||||
;; raise an error if they are present
|
||||
(define (check-unsupported-features id-table)
|
||||
(for ([form unsupported-forms])
|
||||
(define entry (dict-ref id-table form null))
|
||||
(unless (null? entry)
|
||||
(tc-error/stx
|
||||
(car entry)
|
||||
"unsupported class clause: ~a"
|
||||
(syntax-e form)))))
|
||||
;; check-unsupported-feature : Identifier Syntax -> Void
|
||||
;; Check if the given identifier corresponds to an unsupported class form
|
||||
;; and emit an error using the given syntax object if it does
|
||||
(define (check-unsupported-feature id stx)
|
||||
(when (member id unsupported-forms free-identifier=?)
|
||||
(tc-error/stx id "unsupported class clause: ~a" stx)))
|
||||
|
||||
;; make-class-name-table : Listof<Id> Listof<Id> Listof<Id>
|
||||
;; Listof<Id> Dict<Id, Id> -> Stx
|
||||
;; do-make-class-name-table : Listof<Id> Listof<Clause> Listof<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
|
||||
ordered-inits
|
||||
optional-inits
|
||||
name-dict)
|
||||
(define (do-make-class-name-table foralls
|
||||
clauses
|
||||
private-fields)
|
||||
(define (get-names kind)
|
||||
(clauses->names (λ (clause)
|
||||
(free-identifier=? (clause-kind clause) kind))
|
||||
clauses #t))
|
||||
(tr:class:name-table-property
|
||||
(internal
|
||||
#`(class-internal
|
||||
(#:forall #,@foralls)
|
||||
(#:all-inits #,@ordered-inits)
|
||||
(#: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 '()))
|
||||
(#:all-inits #,@(get-all-init-names clauses))
|
||||
(#:init #,@(get-names #'untyped:init))
|
||||
(#:init-field #,@(get-names #'untyped:init-field))
|
||||
(#:init-rest #,@(get-names #'untyped:init-rest))
|
||||
(#:optional-init #,@(get-optional-inits clauses))
|
||||
(#:field #,@(get-names #'untyped:field))
|
||||
(#:public #,@(get-names #'untyped:public))
|
||||
(#:override #,@(get-names #'untyped:override))
|
||||
(#:private #,@(get-names #'untyped: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 '()))))
|
||||
(#: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
|
||||
;;
|
||||
|
|
@ -517,25 +330,22 @@
|
|||
;; The identifiers inside the lambdas below will expand via
|
||||
;; set!-transformers to the appropriate accessors, which lets
|
||||
;; us figure out the accessor identifiers.
|
||||
(define (make-locals-table name-dict private-field-names)
|
||||
(define public-names
|
||||
(stx-map stx-car (dict-ref name-dict #'public '())))
|
||||
(define override-names
|
||||
(stx-map stx-car (dict-ref name-dict #'override '())))
|
||||
(define private-names (dict-ref name-dict #'private '()))
|
||||
(define field-names
|
||||
(append (stx-map stx-car (dict-ref name-dict #'field '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'init-field '()))))
|
||||
(define init-names
|
||||
(stx-map stx-car (dict-ref name-dict #'init '())))
|
||||
(define init-rest-name (dict-ref name-dict #'init-rest '()))
|
||||
(define inherit-names
|
||||
(stx-map stx-car (dict-ref name-dict #'inherit '())))
|
||||
(define inherit-field-names
|
||||
(stx-map stx-car (dict-ref name-dict #'inherit-field '())))
|
||||
(define augment-names
|
||||
(append (stx-map stx-car (dict-ref name-dict #'pubment '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'augment '()))))
|
||||
(define (do-make-locals-table clauses private-field-names)
|
||||
(define (get-names kind)
|
||||
(clauses->names (λ (clause)
|
||||
(free-identifier=? (clause-kind clause) kind))
|
||||
clauses))
|
||||
(define public-names (get-names #'untyped:public))
|
||||
(define override-names (get-names #'untyped:override))
|
||||
(define private-names (get-names #'untyped:private))
|
||||
(define field-names (append (get-names #'untyped:field)
|
||||
(get-names #'untyped:init-field)))
|
||||
(define init-names (get-names #'untyped:init))
|
||||
(define init-rest-name (get-names #'untyped:init-rest))
|
||||
(define inherit-names (get-names #'untyped:inherit))
|
||||
(define inherit-field-names (get-names #'untyped:inherit-field))
|
||||
(define augment-names (append (get-names #'untyped:pubment)
|
||||
(get-names #'untyped:augment)))
|
||||
(tr:class:local-table-property
|
||||
#`(let-values ([(#,@public-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx)))
|
||||
|
|
@ -562,10 +372,10 @@
|
|||
(values #,@(map (λ (stx) #`(λ () (#,stx)))
|
||||
inherit-names))]
|
||||
[(#,@override-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx) (super #,stx)))
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx) (untyped:super #,stx)))
|
||||
override-names))]
|
||||
[(#,@augment-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx)))
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx) (untyped:inner #f #,stx)))
|
||||
augment-names))])
|
||||
(void))
|
||||
#t)))
|
||||
|
|
|
|||
|
|
@ -73,6 +73,8 @@
|
|||
(tr:class:type-annotation tr:class:type-annotation)
|
||||
(tr:class:super tr:class:super)
|
||||
(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)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@
|
|||
(define-syntax-class internal-class-data
|
||||
#:literal-sets (kernel-literals)
|
||||
#:literals (class-internal values)
|
||||
(pattern (begin (quote-syntax
|
||||
(pattern (let-values ([() (begin (quote-syntax
|
||||
(class-internal
|
||||
(#:forall type-parameter:id ...)
|
||||
(#:all-inits all-init-names:id ...)
|
||||
|
|
@ -80,7 +80,8 @@
|
|||
(#:inherit-field inherit-field-names:name-pair ...)
|
||||
(#:augment augment-names:name-pair ...)
|
||||
(#:pubment pubment-names:name-pair ...)))
|
||||
(#%plain-app values))
|
||||
(#%plain-app values))])
|
||||
_)
|
||||
#:with type-parameters #'(type-parameter ...)
|
||||
#:with all-init-internals #'(all-init-names ...)
|
||||
#:with init-internals #'(init-names.internal ...)
|
||||
|
|
@ -153,30 +154,11 @@
|
|||
(define-syntax-class class-expansion
|
||||
#:literals (let-values letrec-syntaxes+values #%plain-app quote)
|
||||
#: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
|
||||
initializer-body
|
||||
initializer-self-id
|
||||
initializer-args-id)
|
||||
(pattern (let-values ()
|
||||
(letrec-syntaxes+values
|
||||
()
|
||||
((() ;; residual class: data
|
||||
:internal-class-data))
|
||||
(#%plain-app
|
||||
(pattern (#%plain-app
|
||||
compose-class:id
|
||||
name:expr
|
||||
superclass-expr:expr
|
||||
|
|
@ -184,7 +166,7 @@
|
|||
internal:expr ...
|
||||
(~and make-methods :make-methods-class)
|
||||
(quote :boolean)
|
||||
(quote #f))))))
|
||||
(quote #f))))
|
||||
|
||||
;; This is similar to `type-declaration` from "internal-forms.rkt", but
|
||||
;; the expansion is slightly different in a class so we use this instead.
|
||||
|
|
@ -234,8 +216,12 @@
|
|||
;; FIXME: maybe should check the property on this expression
|
||||
;; as a sanity check too
|
||||
(define super-type (tc-expr #'cls.superclass-expr))
|
||||
(define class-name-table
|
||||
(car (trawl-for-property #'cls.make-methods tr:class:name-table-property)))
|
||||
(syntax-parse class-name-table
|
||||
[tbl:internal-class-data
|
||||
;; Save parse attributes to pass through to helper functions
|
||||
(define type-parameters (syntax->datum #'cls.type-parameters))
|
||||
(define type-parameters (syntax->datum #'tbl.type-parameters))
|
||||
(define fresh-parameters (map gensym type-parameters))
|
||||
(define parse-info
|
||||
(hash 'type-parameters type-parameters
|
||||
|
|
@ -245,78 +231,78 @@
|
|||
'initializer-self-id #'cls.initializer-self-id
|
||||
'initializer-args-id #'cls.initializer-args-id
|
||||
'initializer-body #'cls.initializer-body
|
||||
'optional-inits (syntax->datum #'cls.optional-inits)
|
||||
'only-init-internals (syntax->datum #'cls.init-internals)
|
||||
'only-init-names (syntax->datum #'cls.init-externals)
|
||||
'optional-inits (syntax->datum #'tbl.optional-inits)
|
||||
'only-init-internals (syntax->datum #'tbl.init-internals)
|
||||
'only-init-names (syntax->datum #'tbl.init-externals)
|
||||
;; the order of these names reflect the order in the class,
|
||||
;; so use this list when retaining the order is important
|
||||
'init-internals (syntax->datum #'cls.all-init-internals)
|
||||
'init-rest-name (and (attribute cls.init-rest-name)
|
||||
(syntax-e (attribute cls.init-rest-name)))
|
||||
'public-internals (syntax->datum #'cls.public-internals)
|
||||
'override-internals (syntax->datum #'cls.override-internals)
|
||||
'pubment-internals (syntax->datum #'cls.pubment-internals)
|
||||
'augment-internals (syntax->datum #'cls.augment-internals)
|
||||
'init-internals (syntax->datum #'tbl.all-init-internals)
|
||||
'init-rest-name (and (attribute tbl.init-rest-name)
|
||||
(syntax-e (attribute tbl.init-rest-name)))
|
||||
'public-internals (syntax->datum #'tbl.public-internals)
|
||||
'override-internals (syntax->datum #'tbl.override-internals)
|
||||
'pubment-internals (syntax->datum #'tbl.pubment-internals)
|
||||
'augment-internals (syntax->datum #'tbl.augment-internals)
|
||||
'method-internals
|
||||
(set-union (syntax->datum #'cls.public-internals)
|
||||
(syntax->datum #'cls.override-internals))
|
||||
(set-union (syntax->datum #'tbl.public-internals)
|
||||
(syntax->datum #'tbl.override-internals))
|
||||
'field-internals
|
||||
(set-union (syntax->datum #'cls.field-internals)
|
||||
(syntax->datum #'cls.init-field-internals))
|
||||
(set-union (syntax->datum #'tbl.field-internals)
|
||||
(syntax->datum #'tbl.init-field-internals))
|
||||
'inherit-internals
|
||||
(syntax->datum #'cls.inherit-internals)
|
||||
(syntax->datum #'tbl.inherit-internals)
|
||||
'inherit-field-internals
|
||||
(syntax->datum #'cls.inherit-field-internals)
|
||||
(syntax->datum #'tbl.inherit-field-internals)
|
||||
'init-names
|
||||
(set-union (syntax->datum #'cls.init-externals)
|
||||
(syntax->datum #'cls.init-field-externals))
|
||||
(set-union (syntax->datum #'tbl.init-externals)
|
||||
(syntax->datum #'tbl.init-field-externals))
|
||||
'field-names
|
||||
(set-union (syntax->datum #'cls.field-externals)
|
||||
(syntax->datum #'cls.init-field-externals))
|
||||
'public-names (syntax->datum #'cls.public-externals)
|
||||
'override-names (syntax->datum #'cls.override-externals)
|
||||
'pubment-names (syntax->datum #'cls.pubment-externals)
|
||||
'augment-names (syntax->datum #'cls.augment-externals)
|
||||
'inherit-names (syntax->datum #'cls.inherit-externals)
|
||||
(set-union (syntax->datum #'tbl.field-externals)
|
||||
(syntax->datum #'tbl.init-field-externals))
|
||||
'public-names (syntax->datum #'tbl.public-externals)
|
||||
'override-names (syntax->datum #'tbl.override-externals)
|
||||
'pubment-names (syntax->datum #'tbl.pubment-externals)
|
||||
'augment-names (syntax->datum #'tbl.augment-externals)
|
||||
'inherit-names (syntax->datum #'tbl.inherit-externals)
|
||||
'inherit-field-names
|
||||
(syntax->datum #'cls.inherit-field-externals)
|
||||
'private-names (syntax->datum #'cls.private-names)
|
||||
'private-fields (syntax->datum #'cls.private-field-names)
|
||||
(syntax->datum #'tbl.inherit-field-externals)
|
||||
'private-names (syntax->datum #'tbl.private-names)
|
||||
'private-fields (syntax->datum #'tbl.private-field-names)
|
||||
'overridable-names
|
||||
(set-union (syntax->datum #'cls.public-externals)
|
||||
(syntax->datum #'cls.override-externals))
|
||||
(set-union (syntax->datum #'tbl.public-externals)
|
||||
(syntax->datum #'tbl.override-externals))
|
||||
'augmentable-names
|
||||
(set-union (syntax->datum #'cls.pubment-externals)
|
||||
(syntax->datum #'cls.augment-externals))
|
||||
(set-union (syntax->datum #'tbl.pubment-externals)
|
||||
(syntax->datum #'tbl.augment-externals))
|
||||
'method-names
|
||||
(set-union (syntax->datum #'cls.public-externals)
|
||||
(syntax->datum #'cls.override-externals)
|
||||
(syntax->datum #'cls.augment-externals)
|
||||
(syntax->datum #'cls.pubment-externals))
|
||||
(set-union (syntax->datum #'tbl.public-externals)
|
||||
(syntax->datum #'tbl.override-externals)
|
||||
(syntax->datum #'tbl.augment-externals)
|
||||
(syntax->datum #'tbl.pubment-externals))
|
||||
'all-internal
|
||||
(append (syntax->datum #'cls.init-internals)
|
||||
(syntax->datum #'cls.init-field-internals)
|
||||
(syntax->datum #'cls.field-internals)
|
||||
(syntax->datum #'cls.public-internals)
|
||||
(syntax->datum #'cls.override-internals)
|
||||
(syntax->datum #'cls.inherit-internals)
|
||||
(syntax->datum #'cls.inherit-field-internals)
|
||||
(syntax->datum #'cls.pubment-internals)
|
||||
(syntax->datum #'cls.augment-internals))
|
||||
(append (syntax->datum #'tbl.init-internals)
|
||||
(syntax->datum #'tbl.init-field-internals)
|
||||
(syntax->datum #'tbl.field-internals)
|
||||
(syntax->datum #'tbl.public-internals)
|
||||
(syntax->datum #'tbl.override-internals)
|
||||
(syntax->datum #'tbl.inherit-internals)
|
||||
(syntax->datum #'tbl.inherit-field-internals)
|
||||
(syntax->datum #'tbl.pubment-internals)
|
||||
(syntax->datum #'tbl.augment-internals))
|
||||
'all-external
|
||||
(append (syntax->datum #'cls.init-externals)
|
||||
(syntax->datum #'cls.init-field-externals)
|
||||
(syntax->datum #'cls.field-externals)
|
||||
(syntax->datum #'cls.public-externals)
|
||||
(syntax->datum #'cls.override-externals)
|
||||
(syntax->datum #'cls.inherit-externals)
|
||||
(syntax->datum #'cls.inherit-field-externals)
|
||||
(syntax->datum #'cls.pubment-externals)
|
||||
(syntax->datum #'cls.augment-externals))))
|
||||
(append (syntax->datum #'tbl.init-externals)
|
||||
(syntax->datum #'tbl.init-field-externals)
|
||||
(syntax->datum #'tbl.field-externals)
|
||||
(syntax->datum #'tbl.public-externals)
|
||||
(syntax->datum #'tbl.override-externals)
|
||||
(syntax->datum #'tbl.inherit-externals)
|
||||
(syntax->datum #'tbl.inherit-field-externals)
|
||||
(syntax->datum #'tbl.pubment-externals)
|
||||
(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 expected super-type parse-info)))])]))
|
||||
|
||||
;; do-check : Type Type Dict -> Type
|
||||
;; The actual type-checking
|
||||
|
|
|
|||
|
|
@ -6,7 +6,9 @@
|
|||
(require "../utils/utils.rkt"
|
||||
(rep type-rep rep-utils)
|
||||
(types resolve)
|
||||
(except-in racket/class private)
|
||||
(prefix-in untyped: racket/class)
|
||||
(except-in (base-env class-clauses)
|
||||
private)
|
||||
racket/dict
|
||||
racket/list
|
||||
racket/match
|
||||
|
|
@ -14,7 +16,7 @@
|
|||
syntax/stx
|
||||
(only-in unstable/list check-duplicate)
|
||||
(only-in unstable/sequence in-syntax)
|
||||
(for-template racket/class))
|
||||
(for-template (base-env class-clauses)))
|
||||
|
||||
(provide Class:
|
||||
row-constraints
|
||||
|
|
@ -25,6 +27,11 @@
|
|||
object-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
|
||||
;;
|
||||
;; A RowConstraint is a
|
||||
|
|
@ -37,11 +44,11 @@
|
|||
|
||||
;; Syntax classes for rows
|
||||
(define-splicing-syntax-class row-constraints
|
||||
#:literals (init init-field field augment)
|
||||
(pattern (~seq (~or (init iname:id ...)
|
||||
(init-field ifname:id ...)
|
||||
(field fname:id ...)
|
||||
(augment aname:id ...)
|
||||
#:literal-sets (class-type-literals)
|
||||
(pattern (~seq (~or ((~or init untyped:init) iname:id ...)
|
||||
((~or init-field untyped:init-field) ifname:id ...)
|
||||
((~or field untyped:field) fname:id ...)
|
||||
((~or augment untyped:augment) aname:id ...)
|
||||
mname:id)
|
||||
...)
|
||||
#:attr init-names (flatten/datum #'((iname ...) ...))
|
||||
|
|
@ -92,8 +99,9 @@
|
|||
(define-splicing-syntax-class (row-clauses parse-type)
|
||||
#:description "Row type clause"
|
||||
#:attributes (row)
|
||||
#:literals (init-rest)
|
||||
(pattern (~seq (~or (~optional (init-rest init-rest-type:expr))
|
||||
#:literal-sets (class-type-literals)
|
||||
(pattern (~seq (~or (~optional ((~or init-rest untyped:init-rest)
|
||||
init-rest-type:expr))
|
||||
(~var clause (type-clause parse-type)))
|
||||
...)
|
||||
#:attr inits (apply append (attribute clause.init-entries))
|
||||
|
|
@ -180,8 +188,9 @@
|
|||
(define-splicing-syntax-class object-type-clauses
|
||||
#:description "Object type clause"
|
||||
#:attributes (field-names field-types method-names method-types)
|
||||
#:literals (field)
|
||||
(pattern (~seq (~or (field field-clause:field-or-method-type ...)
|
||||
#:literal-sets (class-type-literals)
|
||||
(pattern (~seq (~or ((~or field untyped:field)
|
||||
field-clause:field-or-method-type ...)
|
||||
method-clause:field-or-method-type)
|
||||
...)
|
||||
#:with field-names (flatten-class-clause #'((field-clause.label ...) ...))
|
||||
|
|
@ -204,10 +213,11 @@
|
|||
#:description "Class type clause"
|
||||
#:attributes (row-var extends-types
|
||||
inits fields methods augments init-rest)
|
||||
#:literals (init-rest)
|
||||
#:literal-sets (class-type-literals)
|
||||
(pattern (~seq (~or (~optional (~seq #:row-var row-var: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)))
|
||||
...)
|
||||
#:attr inits (apply append (attribute clause.init-entries))
|
||||
|
|
@ -250,8 +260,8 @@
|
|||
(define-syntax-class (type-clause parse-type)
|
||||
#:attributes (init-entries field-entries
|
||||
method-entries augment-entries)
|
||||
#:literals (init init-field field augment)
|
||||
(pattern (init init-clause:init-type ...)
|
||||
#:literal-sets (class-type-literals)
|
||||
(pattern ((~or init untyped:init) init-clause:init-type ...)
|
||||
#:attr init-entries
|
||||
(make-init-entries
|
||||
#'(init-clause.label ...)
|
||||
|
|
@ -261,7 +271,8 @@
|
|||
#:attr field-entries null
|
||||
#:attr method-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
|
||||
(make-init-entries
|
||||
#'(init-field-clause.label ...)
|
||||
|
|
@ -275,7 +286,7 @@
|
|||
parse-type)
|
||||
#:attr method-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 field-entries
|
||||
(make-field/augment-entries
|
||||
|
|
@ -284,7 +295,8 @@
|
|||
parse-type)
|
||||
#:attr method-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 field-entries null
|
||||
#:attr method-entries null
|
||||
|
|
|
|||
|
|
@ -1,18 +1,9 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (except-in racket/class
|
||||
class
|
||||
define/public
|
||||
define/override
|
||||
define/pubment
|
||||
define/augment
|
||||
define/private)
|
||||
(require racket/require
|
||||
(subtract-in racket/class
|
||||
typed-racket/base-env/class-prims)
|
||||
typed-racket/base-env/class-prims)
|
||||
|
||||
(provide class
|
||||
define/public
|
||||
define/override
|
||||
define/pubment
|
||||
define/augment
|
||||
define/private
|
||||
(provide (all-from-out typed-racket/base-env/class-prims)
|
||||
(all-from-out racket/class))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/class
|
||||
(require typed/racket/class
|
||||
typed/private/utils)
|
||||
|
||||
(provide Frame%
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(provide fish%))
|
||||
|
||||
(module fish-client typed/racket/base
|
||||
(require racket/class)
|
||||
(require typed/racket/class)
|
||||
(require/typed (submod ".." fish) [fish% Fish%])
|
||||
|
||||
(define-type-alias Fish% (Class (init [weight Real])
|
||||
|
|
|
|||
|
|
@ -17,9 +17,7 @@
|
|||
|
||||
;; see typecheck-tests.rkt for rationale on imports
|
||||
(require rackunit
|
||||
(except-in racket/class
|
||||
class define/public define/override
|
||||
define/pubment define/augment define/private)
|
||||
typed/racket/class
|
||||
(except-in typed-racket/utils/utils private)
|
||||
(except-in (base-env extra-procs prims class-prims
|
||||
base-types base-types-extra)
|
||||
|
|
@ -1325,8 +1323,8 @@
|
|||
(super-new)
|
||||
(: x String)
|
||||
(field [x : Symbol 0]))
|
||||
#:ret (ret (-class #:field ([x -Symbol])))
|
||||
#:msg #rx"duplicate type annotation.*new type: String"]
|
||||
#:ret (ret (-class #:field ([x -String])))
|
||||
#:msg #rx"duplicate type annotation.*new type: Symbol"]
|
||||
;; fails, expected type and annotation don't match
|
||||
[tc-err (let ()
|
||||
(: c% (Class (field [x String])))
|
||||
|
|
|
|||
|
|
@ -10,7 +10,10 @@
|
|||
syntax/parse
|
||||
syntax/stx
|
||||
;; 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)
|
||||
(gen-test-main)
|
||||
|
|
@ -44,22 +47,6 @@
|
|||
(check-true (syntax-parses? #'([x y]) init-decl))
|
||||
(check-true (syntax-parses? #'(x 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
|
||||
(get-optional-inits
|
||||
|
|
@ -67,5 +54,5 @@
|
|||
(list #f) (list #t))
|
||||
(init-clause #'(init [(a b)]) #'init #'([a b])
|
||||
(list #f) (list #f))))
|
||||
(list #'x)))))
|
||||
(list #'x))))
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@
|
|||
(base-env base-types base-types-extra colon)
|
||||
;; needed for parsing case-lambda/case-> types
|
||||
(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)
|
||||
|
||||
|
|
@ -261,6 +262,8 @@
|
|||
[(Class) (-class)]
|
||||
[(Class (init [x Number] [y Number]))
|
||||
(-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 #f] [y -Number #t]))]
|
||||
[(Class (init [x Number]) (init-field [y Number]))
|
||||
|
|
@ -271,8 +274,12 @@
|
|||
(-class #:init ([x -Number #f]) #:method ([m (t:-> N N)]))]
|
||||
[(Class [m (Number -> Number)] (field [x Number]))
|
||||
(-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 (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 (t:-> N N)]) #:field ([x -Number]))]
|
||||
[(Class (augment [m (-> Number)]) [m (-> Number)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user