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

Add #:implements/inits for Class types

Browse Source 
Allows some Class types to be written more concisely.
This commit is contained in:
Asumu Takikawa 2014-10-17 17:03:16 -04:00
parent 3d175cedc8
commit 56e7026b16
4 changed files with 111 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -252,6 +252,7 @@ additional provides all other bindings from @racketmodname[racket/class].
(field name+type ...)
(augment name+type ...)
(code:line #:implements type-alias-id)
(code:line #:implements/inits inits-id)
(code:line #:row-var row-var-id)]
[init-type name+type
[id type #:optional]]
@ -282,7 +283,8 @@ additional provides all other bindings from @racketmodname[racket/class].
The order of initialization arguments in the type is significant, because
it determines the types of by-position arguments for use with
@racket[make-object] and @racket[instantiate].
@racket[make-object] and @racket[instantiate]. A given @racket[Class] type
may also only contain a single @racket[init-rest] clause.
@ex[
(define drink%
@ -300,6 +302,15 @@ additional provides all other bindings from @racketmodname[racket/class].
for a subclass to include parts of its parent class type. The initialization argument
types of the parent, however, are @emph{not} included because a subclass does not necessarily
share the same initialization arguments as its parent class.
Initialization argument types can be included from the parent by providing
@racket[inits-id] with the @racket[#:implements/inits] keyword. This is identical
to the @racket[#:implements] clause except for the initialization argument
behavior. Only a single @racket[#:implements/inits] clause may be provided for
a single @racket[Class] type. The initialization arguments copied from the parent
type are appended to the initialization arguments specified via the @racket[init]
and @racket[init-field] clauses.
Multiple @racket[#:implements] clauses may be provided for a single class
type.

40
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -731,8 +731,14 @@
(syntax-parse stx
[(kw (~var clause (class-type-clauses parse-type)))
(add-disappeared-use #'kw)
(define parent-stxs (stx->list #'clause.extends-types))
(define parent-types (map parse-type parent-stxs))
(define parent-stxs (stx->list #'clause.implements))
(define parent/init-stx (attribute clause.implements/inits))
(define parent/init-type (and parent/init-stx (parse-type parent/init-stx)))
(define parent-types
(let ([types (map parse-type parent-stxs)])
(if parent/init-stx
(cons parent/init-type types)
types)))
(define given-inits (attribute clause.inits))
(define given-fields (attribute clause.fields))
(define given-methods (attribute clause.methods))
@ -755,7 +761,7 @@
;; Only proceed to create a class type when the parsing
;; process isn't looking for recursive type alias references.
;; (otherwise the merging process will error)
[(or (null? parent-stxs)
[(or (and (null? parent-stxs) (not parent/init-stx))
(not (current-referenced-aliases)))
(check-function-types given-methods)
@ -768,7 +774,8 @@
[methods given-methods]
[augments given-augments])
([parent-type parent-types]
[parent-stx parent-stxs])
[parent-stx (append (or (list parent/init-stx) null)
parent-stxs)])
(merge-with-parent-type row-var parent-type parent-stx
fields methods augments)))
@ -780,8 +787,15 @@
(check-constraints methods (caddr constraints))
(check-constraints augments (cadddr constraints)))
;; For the #:implements/inits entry, put the inits into the type
;; as well. They are appended at the end to match the runtime behavior
;; of init arguments.
(define parent-inits (get-parent-inits parent/init-type))
(define class-type
(make-Class row-var given-inits fields methods augments given-init-rest))
(make-Class row-var
(append given-inits parent-inits)
fields methods augments given-init-rest))
class-type]
[else
@ -809,12 +823,26 @@
(set-box! alias-box (cons (current-type-alias-name)
(unbox alias-box)))
(define class-box (current-referenced-class-parents))
(set-box! class-box (append parent-stxs (unbox class-box)))
(set-box! class-box (append (if parent/init-stx
(cons parent/init-stx parent-stxs)
parent-stxs)
(unbox class-box)))
;; Ok to return Error here, since this type will
;; get reparsed in another pass
(make-Error)
])]))
;; get-parent-inits : (U Type #f) -> Inits
;; Extract the init arguments out of a parent class type
(define (get-parent-inits parent)
(cond [(not parent) null]
[else
(define resolved (resolve parent))
(match resolved
[(Class: _ inits _ _ _ _) inits]
[_ (parse-error "expected a class type for #:implements/inits clause"
"given" resolved)])]))
;; check-function-types : Dict<Name, Type> -> Void
;; ensure all types recorded in the dictionary are function types
(define (check-function-types method-types)

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

@ -211,11 +211,12 @@
;; dependencies
(define-splicing-syntax-class (class-type-clauses parse-type)
#:description "Class type clause"
#:attributes (row-var extends-types
#:attributes (row-var implements implements/inits
inits fields methods augments init-rest)
#:literal-sets (class-type-literals)
(pattern (~seq (~or (~optional (~seq #:row-var row-var:id))
(~seq #:implements extends-type:id)
(~seq #:implements implements-id:id)
(~optional (~seq #:implements/inits implements/inits:id))
(~optional ((~or init-rest untyped:init-rest)
init-rest-type:expr))
(~var clause (type-clause parse-type)))
@ -226,7 +227,7 @@
#:attr augments (apply append (attribute clause.augment-entries))
#:attr init-rest (and (attribute init-rest-type)
(parse-type (attribute init-rest-type)))
#:with extends-types #'(extends-type ...)
#:with implements #'(implements-id ...)
#:fail-when
(check-duplicate (map first (attribute inits)))
"duplicate init or init-field clause"

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

@ -1572,4 +1572,64 @@
(define/augment (m x) (inner 'bar-m m x))
(define/augment (o x y) (inner 'bar-o o x y))))
(void))
-Void]))
-Void]
;; Test implements clauses
[tc-e (let ()
(define-type-alias A% (Class [foo (-> Void)]))
(define-type-alias B% (Class #:implements A% [bar (-> Void)]))
(: b% B%)
(define b% (class object%
(super-new)
(define/public (foo) (void))
(define/public (bar) (void))))
(new b%))
(-object #:method ([foo (t:-> -Void)] [bar (t:-> -Void)]))]
[tc-err (let ()
(define-type-alias A% (Class [foo (-> Void)]))
(define-type-alias B% (Class #:implements A% [bar (-> Void)]))
(: b% B%)
(define b% (class object%
(super-new)
(define/public (bar) (void))))
(error "foo"))
#:msg "type mismatch.*required public method"]
[tc-e (let ()
(define-type-alias A% (Class (init [y Symbol])))
(define-type-alias B% (Class #:implements/inits A% (init [x String])))
(: b% B%)
(define b% (class object%
(super-new)
(init x y)))
(make-object b% "foo" 'bar)
(void))
-Void]
[tc-e (let ()
(define-type-alias A% (Class (init [y Symbol])))
(define-type-alias B% (Class [m (-> Void)]))
(define-type-alias C% (Class #:implements/inits A%
#:implements B%
(init [x String])))
(: c% C%)
(define c% (class object%
(super-new)
(define/public (m) (void))
(init x y)))
(make-object c% "foo" 'bar)
(void))
-Void]
[tc-err (let ()
(define-type-alias A% (Class (init [y String])))
(define-type-alias B% (Class #:implements/inits A%
#:implements/inits A%))
(error "foo"))
;; FIXME: this error message is pretty bad
#:msg "expected Class type clause"]
[tc-err (let ()
(define-type-alias A% (Class (init [y String])))
(define-type-alias B% (Class #:implements/inits A% (init [x String])))
(: b% B%)
(define b% (class object%
(super-new)
(init y x)))
(error "foo"))
#:msg "type mismatch"]))