suzanne.soy/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
This commit is contained in:
Asumu Takikawa 2013-05-24 12:33:14 -04:00
parent f84cf996c3
commit cc61f0639e
2 changed files with 35 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
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) (only-in racket/class init init-field field)
(for-template (only-in racket/class init init-field field)) (for-template (only-in racket/class init init-field field))
(only-in racket/list flatten) (only-in racket/list flatten)
racket/dict
racket/match racket/match
racket/syntax racket/syntax
(only-in unstable/list check-duplicate) (only-in unstable/list check-duplicate)
@ -593,12 +594,22 @@
;; process-class-clauses : Type FieldDict MethodDict -> FieldDict MethodDict ;; process-class-clauses : Type FieldDict MethodDict -> FieldDict MethodDict
;; Merges #:extends class type and the current class clauses appropriately ;; Merges #:extends class type and the current class clauses appropriately
(define (merge-with-parent-type parent-type fields methods) (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 ;; check for duplicates in a class clause
(define (check-duplicate-clause clause-lst err-msg) (define (check-duplicate-clause names super-names types super-types err-msg)
(define maybe-dup (check-duplicate clause-lst)) (define maybe-dup (check-duplicate (append names super-names)))
(when maybe-dup (cond [maybe-dup
(tc-error err-msg 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) (define-values (super-fields super-methods)
(match parent-type (match parent-type
@ -613,16 +624,20 @@
;; if any duplicates are found between this class and the superclass ;; if any duplicates are found between this class and the superclass
;; type, then raise an error ;; type, then raise an error
(define-values (checked-fields checked-super-fields)
(check-duplicate-clause (check-duplicate-clause
(append field-names super-field-names) field-names super-field-names
"field or init-field name ~a conflicts with #:extends clause") fields super-fields
"field or init-field name ~a conflicts with #:extends clause"))
(define-values (checked-methods checked-super-methods)
(check-duplicate-clause (check-duplicate-clause
(append method-names super-method-names) method-names super-method-names
"method name ~a conflicts with #:extends clause") methods super-methods
"method name ~a conflicts with #:extends clause"))
;; then append the super types if there were no errors ;; then append the super types if there were no errors
(define merged-fields (append super-fields fields)) (define merged-fields (append checked-super-fields checked-fields))
(define merged-methods (append super-methods methods)) (define merged-methods (append checked-super-methods checked-methods))
(values merged-fields merged-methods)) (values merged-fields merged-methods))
;; Syntax (Syntax -> Type) -> Type ;; 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)]) #:extends (Class [n (Number -> Number)])
(field [x Number])) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((n ,(t:-> N N)) (m ,(t:-> N N))))] (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)]) [(Class #:extends (Class (init [x Integer]) [m (Number -> Number)])
(field [x Number])) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))] (make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
[FAIL (Class #:extends Number)] [FAIL (Class #:extends Number)]
[FAIL (Class #:extends Number [m (Number -> Number)])] [FAIL (Class #:extends Number [m (Number -> Number)])]
[FAIL (Class #:extends (Class [m (Number -> Number)]) [m String])] [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 ;; FIXME - add tests for parse-values-type, parse-tc-results