From 3022f91b48e03fd68fc567c289b88846418be004 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 9 Aug 2013 15:51:43 -0400 Subject: [PATCH] Add support for separate augment/pubment interfaces Now a class may have a pubment method that has a different type for being directly called and for being specialized for inner calls. This is actually necessary to type-check interesting uses of pubment/augment. Note that if a class does not provide a type annotation for the augmentation interface, it will be assumed to be the same as the pubment type. original commit: 8ca8eb164205df1850ce677d3e37053712565ed8 --- .../typed-racket/base-env/class-prims.rkt | 24 +++- .../typed-racket/private/parse-type.rkt | 13 +- .../typecheck/check-class-unit.rkt | 133 ++++++++++++------ .../typed-racket/typecheck/tc-send.rkt | 4 +- .../typed-racket/types/classes.rkt | 96 +++++++------ .../typed-racket/unit-tests/class-tests.rkt | 53 ++++++- .../unit-tests/parse-type-tests.rkt | 7 +- 7 files changed, 223 insertions(+), 107 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index 4d97041c..97eab1a4 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -28,17 +28,21 @@ ;; for use in ~literal clauses class-internal optional-init - private-field) + private-field + :-augment) ;; give it a binding, but it shouldn't be used directly (define-syntax (class-internal stx) - (raise-syntax-error "should only be used internally")) + (raise-syntax-error 'class "should only be used internally")) (define-syntax (optional-init stx) - (raise-syntax-error "should only be used internally")) + (raise-syntax-error 'class "should only be used internally")) (define-syntax (private-field stx) - (raise-syntax-error "should only be used internally")) + (raise-syntax-error 'class "should only be used internally")) + +(define-syntax (:-augment stx) + (raise-syntax-error 'class "should only be used internally")) (begin-for-syntax (module+ test (require rackunit)) @@ -47,6 +51,7 @@ (define stop-forms (append (kernel-form-identifier-list) (list + (quote-syntax :) (quote-syntax #%app) (quote-syntax lambda) (quote-syntax init) @@ -344,7 +349,7 @@ ([content contents]) (define stx (non-clause-stx content)) (syntax-parse stx - #:literals (define-values super-new) + #:literals (: define-values super-new) ;; if it's a method definition for a declared method, then ;; mark it as something to type-check [(define-values (id) . rst) @@ -365,6 +370,15 @@ (append rest-top (list content)) (append (syntax->list #'(id ...)) private-fields))] + ;; special : annotation for augment interface + [(: name:id type:expr #:augment augment-type:expr) + (define new-clause + (non-clause #'(quote-syntax (:-augment name augment-type)))) + (define plain-annotation + (non-clause (syntax/loc stx (: name type)))) + (values methods + (append rest-top (list plain-annotation new-clause)) + private-fields)] ;; Identify super-new for the benefit of the type checker [(super-new [init-id init-expr] ...) (define new-non-clause 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 86b3f741..98b1b1b4 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 @@ -631,11 +631,14 @@ (define merged-augments (append checked-super-augments checked-augments)) ;; make sure augments and methods are disjoint - (define maybe-dup (check-duplicate (append (dict-keys merged-methods) - (dict-keys merged-augments)))) - (when maybe-dup - (tc-error (~a "method name " maybe-dup " conflicts with" - " another method name or augmentable method name"))) + (define maybe-dup-method (check-duplicate (dict-keys merged-methods))) + (when maybe-dup-method + (tc-error (~a "method name " maybe-dup-method " conflicts with" + " another method name"))) + (define maybe-dup-augment (check-duplicate (dict-keys merged-augments))) + (when maybe-dup-augment + (tc-error (~a "augmentable method name " maybe-dup-augment " conflicts with" + " another augmentable method name"))) (values (or row-var super-row-var) merged-fields merged-methods merged-augments)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index c44d1aad..e5419a05 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -260,7 +260,14 @@ (values internal external))) ;; trawl the body for top-level expressions (define top-level-exprs (trawl-for-property #'cls.make-methods 'tr:class:top-level)) - (define annotation-table (register-annotations top-level-exprs)) + ;; augment annotations go in their own table, because they're + ;; the only kind of type annotation that is allowed to be duplicate + ;; (i.e., m can have type Integer -> Integer and an augment type of + ;; String -> String in the separate tables) + (define-values (annotation-table augment-annotation-table) + ((compose (setup-pubment-defaults this%-pubment-names) + register-annotations) + top-level-exprs)) ;; find the `super-new` call (or error if missing) (define super-new-stxs (trawl-for-property #'cls.make-methods 'tr:class:super-new)) (define super-new-stx (check-super-new-exists super-new-stxs)) @@ -286,6 +293,7 @@ (infer-self-type super-row expected annotation-table + augment-annotation-table optional-inits internal-external-mapping remaining-super-inits @@ -358,20 +366,20 @@ (define meth-stxs (trawl-for-property #'cls.make-methods 'tr:class:method)) (define checked-method-types (with-lexical-env/extend lexical-names lexical-types - (check-methods internal-external-mapping meth-stxs methods self-type - #:filter this%-overridable-names))) - (define checked-pubment-types + (check-methods (append this%-pubment-names + this%-overridable-names) + internal-external-mapping meth-stxs + methods self-type))) + (define checked-augment-types (with-lexical-env/extend lexical-names lexical-types - (check-methods internal-external-mapping meth-stxs augments self-type - #:filter this%-augmentable-names))) + (check-methods this%-augment-names + internal-external-mapping meth-stxs + augments self-type))) (with-lexical-env/extend lexical-names lexical-types (check-private-methods meth-stxs this%-private-names private-method-types self-type)) (define final-class-type - (merge-types - self-type - checked-method-types - checked-pubment-types)) + (merge-types self-type checked-method-types checked-augment-types)) (check-method-presence-and-absence expected this%-init-names this%-field-names @@ -413,13 +421,15 @@ (dict-keys remaining-super-inits)) exp-init-names "initialization argument") - (check-same (set-union this%-public-names super-method-names) + (check-same (set-union this%-public-names this%-pubment-names + super-method-names) exp-method-names "public method") (check-same (set-union this%-field-names super-field-names) exp-field-names "public field") - (check-same (set-union this%-pubment-names super-augment-names) + (check-same (set-union this%-pubment-names this%-augment-names + super-augment-names) exp-augment-names "public augmentable method") (check-same optional-external exp-optional-inits @@ -442,7 +452,7 @@ ;; Given a self object type, construct the real class type based on ;; new information found from type-checking. Only used when an expected ;; type was not provided. -(define (merge-types self-type method-types pubment-types) +(define (merge-types self-type method-types augment-types) (match-define (Instance: (and class-type @@ -454,12 +464,15 @@ (define old-type (dict-ref methods name #f)) ;; sanity check, to ensure that the actual method type ;; is as precise as the annotated type + ;; FIXME: should this be a type error and not internal? (when (and old-type (not (subtype (car type) (car old-type)))) - (int-err "merge-types: actual type not a subtype of annotated type")) + (int-err (~a "merge-types: actual type ~a not" + " a subtype of annotated type ~a") + (car type) (car old-type))) (dict-set methods name type))) (make-Class row-var inits fields (make-new-methods methods method-types) - (make-new-methods augments pubment-types))) + (make-new-methods augments augment-types))) ;; local-tables->lexical-env : Dict ;; LocalMapping NameTypeDict Names @@ -585,7 +598,7 @@ (define super-call-types (make-private-like-types override-names super-types)) (define pubment-types - (make-private-like-types pubment-names augments)) + (make-private-like-types pubment-names methods)) (define init-types (for/list ([i (in-set init-names)]) @@ -627,12 +640,11 @@ init-types (list self-type (make-Univ))))) -;; check-methods : Listof Dict Dict Type +;; check-methods : Listof Listof Dict Dict Type ;; -> Dict ;; Type-check the methods inside of a class -(define (check-methods internal-external-mapping - meths methods self-type - #:filter [filter #f]) +(define (check-methods names-to-check internal-external-mapping + meths methods self-type) (for/fold ([checked '()]) ([meth meths]) (define method-name (syntax-property meth 'tr:class:method)) @@ -641,7 +653,8 @@ (cond [(and maybe-expected ;; fall back to tc-expr/t if the annotated type ;; was the default type (Procedure) - (not (equal? (car maybe-expected) top-func))) + (not (equal? (car maybe-expected) top-func)) + (set-member? names-to-check external-name)) (define pre-method-type (car maybe-expected)) (define method-type (function->method pre-method-type self-type)) @@ -652,7 +665,7 @@ ;; Only try to type-check if these names are in the ;; filter when it's provided. This allows us to, say, only ;; type-check pubments/augments. - [(and filter (set-member? filter external-name)) + [(set-member? names-to-check external-name) (cons (list external-name (method->function (tc-expr/t meth))) checked)] @@ -945,13 +958,26 @@ (recur-on-all #'(e ...))] [_ '()])) -;; register-annotations : Listof -> Dict +;; register-annotations : Listof +;; -> Dict, Dict ;; Find : annotations and register them, error if duplicates are found ;; TODO: support `define-type`? (define (register-annotations stxs) - (for/fold ([table #hash()]) ([stx stxs]) + ;; check if the key is duplicated and return the new table + ;; (erroring if it is a duplicate) + (define (check-duplicate table name type) + (cond [(and (hash-has-key? table name) + (not (equal? (hash-ref table name) type))) + (tc-error/expr + #:stx #'name + "Duplicate type annotation of ~a for ~a, previous was ~a" + type name (hash-ref table name)) + table] + [else (hash-set table name type)])) + (for/fold ([table #hash()] [augment-table #hash()]) + ([stx stxs]) (syntax-parse stx - #:literals (let-values begin quote-syntax :-internal + #:literals (let-values begin quote-syntax :-internal :-augment #%plain-app values void) [(let-values ((() (begin @@ -960,30 +986,48 @@ (#%plain-app void)) (define name (syntax-e #'name-stx)) (define type (parse-type #'type-stx)) - (cond [(and (hash-has-key? table name) - (not (equal? (hash-ref table name) - type))) - (tc-error/expr - #:stx #'name - "Duplicate type annotation of ~a for ~a, previous was ~a" - type name (hash-ref table name)) - table] - [else (hash-set table name type)])] - [_ table]))) + (values (check-duplicate table name type) augment-table)] + [(quote-syntax (:-augment name-stx:id type-stx)) + (define name (syntax-e #'name-stx)) + (define type (parse-type #'type-stx)) + (values table (check-duplicate augment-table name type))] + [_ (values table augment-table)]))) -;; infer-self-type : RowVar Class Dict Set Dict +;; setup-pubment-defaults : Listof -> +;; Dict Dict -> +;; Dict Dict +;; this does a second pass through the type annotations and adds +;; the pubment types as default augment types if an augment type +;; was not already provided +(define ((setup-pubment-defaults pubment-names) + annotations augment-annotations) + (for/fold ([annotations annotations] + [augment-annotations augment-annotations]) + ([name pubment-names]) + (cond [(and (not (dict-has-key? augment-annotations name)) + (dict-has-key? annotations name)) + (values annotations + (dict-set augment-annotations name + (dict-ref annotations name)))] + [else (values annotations augment-annotations)]))) + +;; infer-self-type : RowVar Class Dict Dict +;; Set Dict ;; Inits Fields Methods ;; Set * 4 -> Type ;; Construct a self object type based on all type annotations ;; and the expected type (define (infer-self-type super-row expected - annotation-table optional-inits + annotation-table augment-annotation-table + optional-inits internal-external-mapping super-inits super-fields super-methods super-augments - inits fields publics augments) - (define (make-type-dict names supers maybe-expected [inits? #f] + inits fields publics pubments) + (define (make-type-dict names supers maybe-expected + #:inits [inits? #f] + #:annotations-from [annotation-table annotation-table] #:default-type [default-type Univ]) (for/fold ([type-dict supers]) ([name names]) @@ -1009,13 +1053,16 @@ [(Class: _ inits fields publics augments) (values inits fields publics augments)] [_ (values #f #f #f #f)])) - (define init-types (make-type-dict inits super-inits expected-inits #t)) + (define init-types (make-type-dict inits super-inits expected-inits + #:inits #t)) (define field-types (make-type-dict fields super-fields expected-fields)) - (define public-types (make-type-dict publics super-methods expected-publics + (define public-types (make-type-dict (append publics pubments) + super-methods expected-publics #:default-type top-func)) (define augment-types (make-type-dict - augments super-augments expected-augments - #:default-type top-func)) + pubments super-augments expected-augments + #:default-type top-func + #:annotations-from augment-annotation-table)) (make-Instance (make-Class super-row init-types field-types public-types augment-types))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt index 542c2e89..0f535fdc 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt @@ -16,10 +16,10 @@ (match rcvr-type [(tc-result1: (Instance: (? Mu? type))) (do-check (ret (make-Instance (unfold type))))] - [(tc-result1: (Instance: (and c (Class: _ _ _ methods augments)))) + [(tc-result1: (Instance: (and c (Class: _ _ _ methods _)))) (match (tc-expr method) [(tc-result1: (Value: (? symbol? s))) - (let* ([ftype (cond [(assq s (append methods augments)) => cadr] + (let* ([ftype (cond [(assq s methods) => cadr] [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] [retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)]) (add-typeof-expr form retval) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt index 87316851..72e2a120 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt @@ -212,9 +212,11 @@ (check-duplicate (map first (attribute fields))) "duplicate field or init-field clause" #:fail-when - (check-duplicate (map first (append (attribute methods) - (attribute augments)))) - "duplicate method or augmentable method clause")) + (check-duplicate (map first (attribute methods))) + "duplicate method clause" + #:fail-when + (check-duplicate (map first (attribute augments))) + "duplicate augment clause")) ;; Stx Stx Listof (Stx -> Type) -> Listof<(List Symbol Type Boolean)> ;; Construct init entries for a dictionary for the class type @@ -237,51 +239,55 @@ #:attributes (init-entries field-entries method-entries augment-entries) #:literals (init init-field field augment) - (pattern (~or (init init-clause:init-type ...) - (init-field init-field-clause:init-type ...) - (field field-clause:field-or-method-type ...) - (augment augment-clause:field-or-method-type ...) - method-clause:field-or-method-type) + (pattern (init init-clause:init-type ...) #:attr init-entries - (append (if (attribute init-clause) - (make-init-entries - #'(init-clause.label ...) - #'(init-clause.type ...) - (attribute init-clause.optional?) - parse-type) - null) - (if (attribute init-field-clause) - (make-init-entries - #'(init-field-clause.label ...) - #'(init-field-clause.type ...) - (attribute init-field-clause.optional?) - parse-type) - null)) + (make-init-entries + #'(init-clause.label ...) + #'(init-clause.type ...) + (attribute init-clause.optional?) + parse-type) + #:attr field-entries null + #:attr method-entries null + #:attr augment-entries null) + (pattern (init-field init-field-clause:init-type ...) + #:attr init-entries + (make-init-entries + #'(init-field-clause.label ...) + #'(init-field-clause.type ...) + (attribute init-field-clause.optional?) + parse-type) #:attr field-entries - (append (if (attribute field-clause) - (make-field/augment-entries - #'(field-clause.label ...) - #'(field-clause.type ...) - parse-type) - null) - (if (attribute init-field-clause) - (make-field/augment-entries - #'(init-field-clause.label ...) - #'(init-field-clause.type ...) - parse-type) - null)) - #:attr method-entries - (if (attribute method-clause) - (list (list (syntax-e #'method-clause.label) - (parse-type #'method-clause.type))) - null) + (make-field/augment-entries + #'(init-field-clause.label ...) + #'(init-field-clause.type ...) + parse-type) + #:attr method-entries null + #:attr augment-entries null) + (pattern (field field-clause:field-or-method-type ...) + #:attr init-entries null + #:attr field-entries + (make-field/augment-entries + #'(field-clause.label ...) + #'(field-clause.type ...) + parse-type) + #:attr method-entries null + #:attr augment-entries null) + (pattern (augment augment-clause:field-or-method-type ...) + #:attr init-entries null + #:attr field-entries null + #:attr method-entries null #:attr augment-entries - (if (attribute augment-clause) - (make-field/augment-entries - #'(augment-clause.label ...) - #'(augment-clause.type ...) - parse-type) - null))) + (make-field/augment-entries + #'(augment-clause.label ...) + #'(augment-clause.type ...) + parse-type)) + (pattern method-clause:field-or-method-type + #:attr init-entries null + #:attr field-entries null + #:attr method-entries + (list (list (syntax-e #'method-clause.label) + (parse-type #'method-clause.type))) + #:attr augment-entries null)) (define-syntax-class init-type #:description "Initialization argument label and type" diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt index 655ff825..e9c9e974 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt @@ -927,8 +927,50 @@ (+ 1 x)))) (send (new c%) m 0)) + ;; make sure augment type is reflected in class type + (check-ok + (: c% (Class (augment [m (String -> Integer)]) + [m (Integer -> Integer)])) + (define c% + (class object% (super-new) + (: m (Integer -> Integer) + #:augment (String -> Integer)) + (define/pubment (m x) x)))) + + ;; pubment with different augment type + (check-ok + (define c% + (class object% + (super-new) + (: m (Integer -> Integer) + #:augment (String -> String)) + (define/pubment (m x) + (inner "" m "foo") 0))) + (define d% + (class c% + (super-new) + (define/augment (m x) + (string-append x "bar")))) + (send (new c%) m 0)) + + ;; fail, bad inner argument + (check-err #:exn #rx"Expected String, but got Integer" + (define c% + (class object% + (super-new) + (: m (Integer -> Integer) + #:augment (String -> String)) + (define/pubment (m x) + (inner "" m x) 0))) + (define d% + (class c% + (super-new) + (define/augment (m x) + (string-append x "bar")))) + (send (new c%) m 0)) + ;; Fail, bad inner default - (check-err + (check-err #:exn #rx"Expected Integer, but got String" (define c% (class object% (super-new) @@ -937,7 +979,7 @@ (inner "foo" m x))))) ;; Fail, wrong number of arguments to inner - (check-err + (check-err #:exn #rx"Wrong number of arguments, expected 2" (define c% (class object% (super-new) @@ -946,7 +988,7 @@ (inner 3 m))))) ;; Fail, bad augment type - (check-err + (check-err #:exn #rx"Expected Integer, but got String" (define c% (class object% (super-new) @@ -959,7 +1001,7 @@ (define/augment (m x) "bad type")))) ;; Fail, cannot augment non-augmentable method - (check-err + (check-err #:exn #rx"superclass missing augmentable method m" (define c% (class object% (super-new) @@ -982,7 +1024,8 @@ ;; Pubment with expected class type (check-ok - (: c% (Class (augment [m (Natural -> Natural)]))) + (: c% (Class [m (Natural -> Natural)] + (augment [m (Natural -> Natural)]))) (define c% (class object% (super-new) 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 08df325b..14956718 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 @@ -218,6 +218,8 @@ (make-Class #f null null null `((m ,(t:-> N N))))] [(Class (augment [m (Number -> Number)]) (field [x Number])) (make-Class #f null `((x ,-Number)) null `((m ,(t:-> N N))))] + [(Class (augment [m (-> Number)]) [m (-> Number)]) + (make-Class #f null null `((m ,(t:-> N))) `((m ,(t:-> N))))] [FAIL (Class foobar)] [FAIL (Class [x UNBOUND])] [FAIL (Class [x Number #:random-keyword])] @@ -229,8 +231,9 @@ [FAIL (Class (init [x Number]) (init [x Number]))] [FAIL (Class (init [x Number]) (init-field [x Number]))] [FAIL (Class (field [x Number]) (init-field [x Number]))] - [FAIL (Class (augment [x (-> Number)]) [x (-> Number)])] - [FAIL (Class (augment [x (-> Number)] [x (-> String)]))] + [FAIL (Class (augment [m (-> Number)] [m (-> Number)]))] + [FAIL (Class (augment [m (-> Number)]) (augment [m (-> Number)]))] + [FAIL (Class [m (-> Number)] [m (-> Number)])] ;; test #:row-var [(All (r #:row) (Class #:row-var r)) (make-PolyRow (list 'r)