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

Add "multiple inheritance" for class types

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-24 12:00:05 -04:00
parent 4543204e85
commit f84cf996c3
2 changed files with 53 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -539,14 +539,14 @@
(define-splicing-syntax-class class-type-clauses (define-splicing-syntax-class class-type-clauses
#:description "Class type clause" #:description "Class type clause"
#:attributes (extends-type #:attributes (extends-types
init-names init-types init-optional?s init-names init-types init-optional?s
init-field-names init-field-types init-field-names init-field-types
init-field-optional?s init-field-optional?s
field-names field-types field-names field-types
method-names method-types) method-names method-types)
#:literals (init init-field field) #:literals (init init-field field)
(pattern (~seq (~or (~optional (~seq #:extends extends-type)) (pattern (~seq (~or (~seq #:extends extends-type:expr)
(init init-clause:init-type ...) (init init-clause:init-type ...)
(init-field init-field-clause:init-type ...) (init-field init-field-clause:init-type ...)
(field field-clause:field-or-method-type ...) (field field-clause:field-or-method-type ...)
@ -563,6 +563,7 @@
#:with field-types (flatten-class-clause #'((field-clause.type ...) ...)) #:with field-types (flatten-class-clause #'((field-clause.type ...) ...))
#:with method-names #'(method-clause.label ...) #:with method-names #'(method-clause.label ...)
#:with method-types #'(method-clause.type ...) #:with method-types #'(method-clause.type ...)
#:with extends-types #'(extends-type ...)
#:fail-when #:fail-when
(check-duplicate-identifier (check-duplicate-identifier
(append (syntax->list #'init-names) (append (syntax->list #'init-names)
@ -589,18 +590,9 @@
#:attributes (label type) #:attributes (label type)
(pattern (label:id type:expr))) (pattern (label:id type:expr)))
;; process-class-clauses : ;; process-class-clauses : Type FieldDict MethodDict -> FieldDict MethodDict
;; (U #f Type)
;; (Listof Symbol) (Listof Type) (Listof Boolean) x2
;; (Listof Symbol) (Listof Type) x2
;; -> (L (List Name Type Boolean)) (L (List Name Type)) (L (List Name Type))
;; Merges #:extends class type and the current class clauses appropriately ;; Merges #:extends class type and the current class clauses appropriately
(define (process-class-clauses maybe-parent (define (merge-with-parent-type parent-type fields methods)
init-names init-types init-optional?s
init-field-names init-field-types
init-field-optional?s
field-names field-types
method-names method-types)
;; (Listof Symbol) String -> Void ;; (Listof Symbol) String -> Void
;; 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 clause-lst err-msg)
@ -608,41 +600,30 @@
(when maybe-dup (when maybe-dup
(tc-error err-msg maybe-dup))) (tc-error err-msg maybe-dup)))
(define-values (super-inits super-fields super-methods) (define-values (super-fields super-methods)
(match maybe-parent (match parent-type
[(Class: _ inits fields methods) [(Class: _ _ fields methods)
(values inits fields methods)] (values fields methods)]
[_ (values null null null)])) [_ (tc-error "expected a class type for #:extends clause")]))
(match-define (list (list super-init-names _ _) ...) super-inits)
(match-define (list (list field-names _) ...) fields)
(match-define (list (list method-names _) ...) methods)
(match-define (list (list super-field-names _) ...) super-fields) (match-define (list (list super-field-names _) ...) super-fields)
(match-define (list (list super-method-names _) ...) super-methods) (match-define (list (list super-method-names _) ...) super-methods)
;; 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
(check-duplicate-clause (check-duplicate-clause
(append field-names init-field-names super-field-names) (append field-names super-field-names)
"field or init-field name ~a conflicts with #:extends clause") "field or init-field name ~a conflicts with #:extends clause")
(check-duplicate-clause (check-duplicate-clause
(append method-names super-method-names) (append method-names super-method-names)
"method name ~a conflicts with #:extends clause") "method name ~a conflicts with #:extends clause")
(define inits
(map list
(append init-names init-field-names)
(append init-types init-field-types)
(append init-optional?s init-field-optional?s)))
;; then append the super types if there were no errors ;; then append the super types if there were no errors
(define fields (define merged-fields (append super-fields fields))
(append (define merged-methods (append super-methods methods))
super-fields (values merged-fields merged-methods))
(map list
(append field-names init-field-names)
(append field-types init-field-types))))
(define methods
(append
super-methods
(map list method-names method-types)))
(values inits fields methods))
;; Syntax (Syntax -> Type) -> Type ;; Syntax (Syntax -> Type) -> Type
;; Parse a (Class ...) type ;; Parse a (Class ...) type
@ -650,23 +631,38 @@
(syntax-parse stx (syntax-parse stx
[(kw clause:class-type-clauses) [(kw clause:class-type-clauses)
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(define parent-type (and (attribute clause.extends-type) (define parent-types
(parse-type (attribute clause.extends-type)))) (stx-map parse-type (stx->list #'clause.extends-types)))
(define-values (inits fields methods)
(process-class-clauses parent-type (define given-inits
(stx-map syntax-e #'clause.init-names) (for/list ([name (append (stx-map syntax-e #'clause.init-names)
(stx-map parse-type #'clause.init-types) (stx-map syntax-e #'clause.init-field-names))]
(attribute clause.init-optional?s) [type (append (stx-map parse-type #'clause.init-types)
(stx-map syntax-e #'clause.init-field-names) (stx-map parse-type #'clause.init-field-types))]
(stx-map parse-type #'clause.init-field-types) [optional? (append (attribute clause.init-optional?s)
(attribute clause.init-field-optional?s) (attribute clause.init-field-optional?s))])
(stx-map syntax-e #'clause.field-names) (list name type optional?)))
(stx-map parse-type #'clause.field-types) (define given-fields
(stx-map syntax-e #'clause.method-names) (for/list ([name (append (stx-map syntax-e #'clause.field-names)
(stx-map parse-type #'clause.method-types))) (stx-map syntax-e #'clause.init-field-names))]
[type (append (stx-map parse-type #'clause.field-types)
(stx-map parse-type #'clause.init-field-types))])
(list name type)))
(define given-methods
(for/list ([name (stx-map syntax-e #'clause.method-names)]
[type (stx-map parse-type #'clause.method-types)])
(list name type)))
;; merge with all given parent types, erroring if needed
(define-values (fields methods)
(for/fold ([fields given-fields]
[methods given-methods])
([parent-type parent-types])
(merge-with-parent-type parent-type fields methods)))
(make-Class (make-Class
#f ;; FIXME: put type if it's a row variable #f ;; FIXME: put type if it's a row variable
inits fields methods)])) given-inits fields methods)]))
(define (parse-tc-results stx) (define (parse-tc-results stx)
(syntax-parse stx (syntax-parse stx

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

@ -225,9 +225,15 @@
;; test #:extends ;; test #:extends
[(Class #:extends (Class [m (Number -> Number)]) (field [x Number])) [(Class #:extends (Class [m (Number -> Number)]) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))] (make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
[(Class #:extends (Class [m (Number -> Number)])
#: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 (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 [m (Number -> Number)])]
[FAIL (Class #:extends (Class [m (Number -> Number)]) [m String])] [FAIL (Class #:extends (Class [m (Number -> Number)]) [m String])]
)) ))