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

Allow duplicate type names if they have the same type

Browse Source 
original commit: cc61f0639ec433061d491ba7bf1023cccaf2020f
This commit is contained in:
Asumu Takikawa 2013-05-24 12:33:14 -04:00
parent 97cd75165d
commit 00a4494ba7
2 changed files with 35 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -13,6 +13,7 @@
(only-in racket/class init init-field field)
(for-template (only-in racket/class init init-field field))
(only-in racket/list flatten)
racket/dict
racket/match
racket/syntax
(only-in unstable/list check-duplicate)
@ -593,12 +594,22 @@
;; process-class-clauses : Type FieldDict MethodDict -> FieldDict MethodDict
;; Merges #:extends class type and the current class clauses appropriately
(define (merge-with-parent-type parent-type fields methods)
;; (Listof Symbol) String -> Void
;; (Listof Symbol) Dict Dict String -> (Values Dict Dict)
;; check for duplicates in a class clause
(define (check-duplicate-clause clause-lst err-msg)
(define maybe-dup (check-duplicate clause-lst))
(when maybe-dup
(tc-error err-msg maybe-dup)))
(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 the same,
;; then let it through and check for any other duplicates
(type-equal? type super-type)
(check-duplicate-clause
(remove maybe-dup names) super-names
(dict-remove types maybe-dup) super-types
err-msg)]
[else (tc-error err-msg maybe-dup)])]
[else (values types super-types)]))
(define-values (super-fields super-methods)
(match parent-type
@ -613,16 +624,20 @@
;; if any duplicates are found between this class and the superclass
;; type, then raise an error
(check-duplicate-clause
(append field-names super-field-names)
"field or init-field name ~a conflicts with #:extends clause")
(check-duplicate-clause
(append method-names super-method-names)
"method name ~a conflicts with #:extends clause")
(define-values (checked-fields checked-super-fields)
(check-duplicate-clause
field-names super-field-names
fields super-fields
"field or init-field name ~a conflicts with #:extends clause"))
(define-values (checked-methods checked-super-methods)
(check-duplicate-clause
method-names super-method-names
methods super-methods
"method name ~a conflicts with #:extends clause"))
;; then append the super types if there were no errors
(define merged-fields (append super-fields fields))
(define merged-methods (append super-methods methods))
(define merged-fields (append checked-super-fields checked-fields))
(define merged-methods (append checked-super-methods checked-methods))
(values merged-fields merged-methods))
;; Syntax (Syntax -> Type) -> Type

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

@ -229,12 +229,19 @@
#:extends (Class [n (Number -> Number)])
(field [x Number]))
(make-Class #f null `((x ,-Number)) `((n ,(t:-> N N)) (m ,(t:-> N N))))]
[(Class #:extends (Class [m (Number -> Number)])
#:extends (Class [m (Number -> Number)])
(field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
[(Class #:extends (Class (init [x Integer]) [m (Number -> Number)])
(field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
[FAIL (Class #:extends Number)]
[FAIL (Class #:extends Number [m (Number -> Number)])]
[FAIL (Class #:extends (Class [m (Number -> Number)]) [m String])]
[FAIL (Class #:extends (Class [m (Number -> Number)])
#:extends (Class [m (String -> String)])
(field [x Number]))]
))
;; FIXME - add tests for parse-values-type, parse-tc-results