From f84cf996c36a78a43a13827411a7d498c6cabf05 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 24 May 2013 12:00:05 -0400 Subject: [PATCH] Add "multiple inheritance" for class types --- .../typed-racket/private/parse-type.rkt | 98 +++++++++---------- .../unit-tests/parse-type-tests.rkt | 6 ++ 2 files changed, 53 insertions(+), 51 deletions(-) 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 93baa81f8f..60ae84c332 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 @@ -539,14 +539,14 @@ (define-splicing-syntax-class class-type-clauses #:description "Class type clause" - #:attributes (extends-type + #:attributes (extends-types 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) #: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-field init-field-clause:init-type ...) (field field-clause:field-or-method-type ...) @@ -563,6 +563,7 @@ #:with field-types (flatten-class-clause #'((field-clause.type ...) ...)) #:with method-names #'(method-clause.label ...) #:with method-types #'(method-clause.type ...) + #:with extends-types #'(extends-type ...) #:fail-when (check-duplicate-identifier (append (syntax->list #'init-names) @@ -589,18 +590,9 @@ #:attributes (label type) (pattern (label:id type:expr))) -;; process-class-clauses : -;; (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)) +;; process-class-clauses : Type FieldDict MethodDict -> FieldDict MethodDict ;; Merges #:extends class type and the current class clauses appropriately -(define (process-class-clauses maybe-parent - 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) +(define (merge-with-parent-type parent-type fields methods) ;; (Listof Symbol) String -> Void ;; check for duplicates in a class clause (define (check-duplicate-clause clause-lst err-msg) @@ -608,41 +600,30 @@ (when maybe-dup (tc-error err-msg maybe-dup))) - (define-values (super-inits super-fields super-methods) - (match maybe-parent - [(Class: _ inits fields methods) - (values inits fields methods)] - [_ (values null null null)])) - (match-define (list (list super-init-names _ _) ...) super-inits) + (define-values (super-fields super-methods) + (match parent-type + [(Class: _ _ fields methods) + (values fields methods)] + [_ (tc-error "expected a class type for #:extends clause")])) + + (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-method-names _) ...) super-methods) ;; if any duplicates are found between this class and the superclass ;; type, then raise an error (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") (check-duplicate-clause (append method-names super-method-names) "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 - (define fields - (append - super-fields - (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)) + (define merged-fields (append super-fields fields)) + (define merged-methods (append super-methods methods)) + (values merged-fields merged-methods)) ;; Syntax (Syntax -> Type) -> Type ;; Parse a (Class ...) type @@ -650,23 +631,38 @@ (syntax-parse stx [(kw clause:class-type-clauses) (add-disappeared-use #'kw) - (define parent-type (and (attribute clause.extends-type) - (parse-type (attribute clause.extends-type)))) - (define-values (inits fields methods) - (process-class-clauses parent-type - (stx-map syntax-e #'clause.init-names) - (stx-map parse-type #'clause.init-types) - (attribute clause.init-optional?s) - (stx-map syntax-e #'clause.init-field-names) - (stx-map parse-type #'clause.init-field-types) - (attribute clause.init-field-optional?s) - (stx-map syntax-e #'clause.field-names) - (stx-map parse-type #'clause.field-types) - (stx-map syntax-e #'clause.method-names) - (stx-map parse-type #'clause.method-types))) + (define parent-types + (stx-map parse-type (stx->list #'clause.extends-types))) + + (define given-inits + (for/list ([name (append (stx-map syntax-e #'clause.init-names) + (stx-map syntax-e #'clause.init-field-names))] + [type (append (stx-map parse-type #'clause.init-types) + (stx-map parse-type #'clause.init-field-types))] + [optional? (append (attribute clause.init-optional?s) + (attribute clause.init-field-optional?s))]) + (list name type optional?))) + (define given-fields + (for/list ([name (append (stx-map syntax-e #'clause.field-names) + (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 #f ;; FIXME: put type if it's a row variable - inits fields methods)])) + given-inits fields methods)])) (define (parse-tc-results stx) (syntax-parse stx diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt index f880e3918a..83f589568a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt @@ -225,9 +225,15 @@ ;; test #:extends [(Class #:extends (Class [m (Number -> Number)]) (field [x Number])) (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)]) (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])] ))