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

Remove the depth subtype check on #:implements

Browse Source 
This check was not really necessary to begin with,
but I thought it might be a useful sanity check. In
retrospect, calling `subtype` here causes other headaches
(such as when registering type aliases) and is confusing
when multiple #:implements are provided.

Instead, the #:implements clauses are just linearized
and the last type for any given method/field is taken.

This may also prevent a heisenbug that occurs in the
GUI framework types. I still don't know the root cause of
that non-determinism though.

Closes PR 14669

original commit: 9b4e3befa3605851f1ee30f20f4a38edd06dd8a9
This commit is contained in:
Asumu Takikawa 2014-11-20 11:50:00 -05:00
parent c57db18ec4
commit 99ebb7e51c
3 changed files with 37 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -312,7 +312,9 @@ additional provides all other bindings from @racketmodname[racket/class].
and @racket[init-field] clauses.
Multiple @racket[#:implements] clauses may be provided for a single class
type.
type. The types for the @racket[#:implements] clauses are merged in order and the
last type for a given method name or field is used (the types in the @racket[Class]
type itself takes precedence).
@ex[
(define-type Point<%> (Class (field [x Real] [y Real])))

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

@ -628,27 +628,14 @@
;; -> Option<Id> FieldDict MethodDict AugmentDict
;; Merges #:implements class type and the current class clauses appropriately
(define (merge-with-parent-type row-var parent-type parent-stx fields methods augments)
;; (Listof Symbol) Dict Dict String -> (Values Dict Dict)
;; check for duplicates in a class clause
(define (check-duplicate-clause names super-names types super-types err-msg)
(define maybe-dup (check-duplicate (append names super-names)))
(cond [maybe-dup
(define type (car (dict-ref types maybe-dup)))
(define super-type (car (dict-ref super-types maybe-dup)))
(cond [;; if there is a duplicate, but the type is a subtype,
;; then let it through and check for any other duplicates
(unless (subtype type super-type)
(parse-error "class member type not a subtype of parent member type"
"member" maybe-dup
"type" type
"parent type" super-type))
(check-duplicate-clause
names (remove maybe-dup super-names)
types (dict-remove super-types maybe-dup)
err-msg)]
[else
(parse-error #:stx parent-stx err-msg "name" maybe-dup)])]
[else (values types super-types)]))
;; merge-clause : Dict Dict -> Dict
;; Merge all the non-duplicate entries from the parent types
(define (merge-clause parent-clause clause)
(for/fold ([clause clause])
([(k v) (in-dict parent-clause)])
(if (dict-has-key? clause k)
clause
(dict-set clause k v))))
(define (match-parent-type parent-type)
(define resolved (resolve parent-type))
@ -668,24 +655,6 @@
(match-define (list (list super-method-names _) ...) super-methods)
(match-define (list (list super-augment-names _) ...) super-augments)
;; if any duplicates are found between this class and the superclass
;; type, then raise an error
(define-values (checked-fields checked-super-fields)
(check-duplicate-clause
field-names super-field-names
fields super-fields
"field or init-field name conflicts with #:implements clause"))
(define-values (checked-methods checked-super-methods)
(check-duplicate-clause
method-names super-method-names
methods super-methods
"method name conflicts with #:implements clause"))
(define-values (checked-augments checked-super-augments)
(check-duplicate-clause
augment-names super-augment-names
augments super-augments
"augmentable method name conflicts with #:implements clause"))
;; it is an error for both the extending type and extended type
;; to have row variables
(when (and row-var super-row-var)
@ -693,9 +662,9 @@
" extend another type that has a row variable")))
;; then append the super types if there were no errors
(define merged-fields (append checked-super-fields checked-fields))
(define merged-methods (append checked-super-methods checked-methods))
(define merged-augments (append checked-super-augments checked-augments))
(define merged-fields (merge-clause super-fields fields))
(define merged-methods (merge-clause super-methods methods))
(define merged-augments (merge-clause super-augments augments))
;; make sure augments and methods are disjoint
(define maybe-dup-method (check-duplicate (dict-keys merged-methods)))
@ -773,9 +742,9 @@
[fields given-fields]
[methods given-methods]
[augments given-augments])
([parent-type parent-types]
[parent-stx (append (or (list parent/init-stx) null)
parent-stxs)])
([parent-type (reverse parent-types)]
[parent-stx (reverse (append (or (list parent/init-stx) null)
parent-stxs))])
(merge-with-parent-type row-var parent-type parent-stx
fields methods augments)))

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

@ -1632,4 +1632,23 @@
(super-new)
(init y x)))
(error "foo"))
#:msg "type mismatch"]))
#:msg "type mismatch"]
;; PR 14669 (next two)
[tc-e (let ()
(define-type-alias A (Class [m (-> Any)]))
(define-type-alias B (Class #:implements A [m (-> Void)]))
(define-type-alias C (Class #:implements A))
(define-type-alias D (Class #:implements C #:implements B))
(: d% D)
(define d% (class object% (super-new) (define/public (m) (void))))
(send (new d%) m))
-Void]
[tc-e (let ()
(define-type-alias A (Class [m (-> Any)]))
(define-type-alias B (Class #:implements A [m (-> Void)]))
(define-type-alias C (Class #:implements A))
(define-type-alias D (Class #:implements B #:implements C))
(: d% D)
(define d% (class object% (super-new) (define/public (m) (void))))
(send (new d%) m))
Univ]))