From 56e7026b165d8a9eb48a5ac004d7769a5a1f264e Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 17 Oct 2014 17:03:16 -0400 Subject: [PATCH] Add #:implements/inits for Class types Allows some Class types to be written more concisely. --- .../scribblings/reference/typed-classes.scrbl | 13 +++- .../typed-racket/private/parse-type.rkt | 40 ++++++++++-- .../typed-racket/types/classes.rkt | 7 ++- .../typed-racket/unit-tests/class-tests.rkt | 62 ++++++++++++++++++- 4 files changed, 111 insertions(+), 11 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl index 470f439318..969259bb35 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl +++ b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl @@ -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. diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index 70cba2dab9..84934d581c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -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 -> Void ;; ensure all types recorded in the dictionary are function types (define (check-function-types method-types) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt index 7770401e65..5d6b8e0145 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt @@ -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" diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt index 082c5ee9d5..7c5ec85035 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt @@ -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"]))