From b5dc5585be568cfe6b3735c3f27398c35b20b054 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 19 Oct 2015 20:27:53 -0400 Subject: [PATCH] Fix part of GH issue #208 For private `define-values` in classes with multiple variables, don't eagerly throw type errors in the synthesis step. Instead, wait until the later checking step when the environment will be correctly set up. When the initial synthesis typecheck fails, yield type Any for the environment. If the typecheck should really fail, this is ok. If not, then the user can add a type annotation. A better long-term strategy is to change the handling of environments so that the type environment gets refined as definitions are checked. This way all annotations that the user writes are factored into the initial environment and unannotated variables will have their types synthesized. --- .../typecheck/check-class-unit.rkt | 70 ++++++++----------- typed-racket-test/unit-tests/class-tests.rkt | 20 +++++- 2 files changed, 49 insertions(+), 41 deletions(-) diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index c4f5d770..3253e3e9 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -550,21 +550,10 @@ #:when (set-member? (hash-ref parse-info 'private-fields) name)) (hash-set! private-field-types name (list type))) - ;; Hash Listof, Listof>> - ;; Maps the outermost `let-values` expressions introduced by the expansion of - ;; `define-values` within the class body to a list of identifier syntaxes - ;; that represent variables and a list of corresponding types. - ;; The variables temporarily hold the values of the initializer expression; - ;; a field mutator is called on each one in the body of the `let-values`. - ;; Typechecking of these calls is done in `check-field-set!s` and requires - ;; the types of the initial values. - (define inits-temporaries-types (make-hasheq)) - (define synthesized-init-val-stxs (synthesize-private-field-types private-field-stxs local-private-field-table - private-field-types - inits-temporaries-types)) + private-field-types)) ;; Detect mutation of private fields for occurrence typing (for ([stx (in-sequences @@ -609,8 +598,7 @@ (with-lexical-env/extend-types lexical-names/top-level lexical-types/top-level (check-field-set!s (hash-ref parse-info 'initializer-body) synthesized-init-val-stxs - inits - inits-temporaries-types)) + inits)) (do-timestamp "checked field initializers") (define checked-method-types (with-lexical-env/extend-types lexical-names lexical-types @@ -1035,11 +1023,11 @@ (tc-expr/t xformed-stx)]))) ;; check-field-set!s : Syntax Listof Dict -;; Dict, Listof> -> Void +;; -> Void ;; Check that fields are initialized to the correct type ;; FIXME: use syntax classes for matching and clearly separate the handling ;; of field initialization and set! uses -(define (check-field-set!s stx synthed-stxs inits inits-temporaries-types) +(define (check-field-set!s stx synthed-stxs inits) (for ([form (syntax->list stx)]) (syntax-parse form #:literal-sets (kernel-literals) @@ -1106,12 +1094,21 @@ (tc-expr/check processed (ret type)))] ;; multiple private fields [(let-values ([(names:id ...) val-expr]) begins ... (#%plain-app _)) - (match-define (list t-names t-types) - (hash-ref inits-temporaries-types form (list empty empty))) + ;; This seems like it's duplicating work since the synthesis pass + ;; earlier had to do this, but it needs to be re-checked in this context + ;; so that it has the right environment. An earlier approach did + ;; check this only in the synthesis stage, but caused some regressions. + (define temp-names (syntax->list #'(names ...))) + (define init-types + (match (tc-expr #'val-expr) + [(tc-results: xs ) xs])) + (unless (= (length temp-names) (length init-types)) + (tc-error/expr "wrong number of values: expected ~a but got ~a" + (length temp-names) (length init-types))) ;; Extend lexical type env with temporaries introduced in the ;; expansion of the field initialization or setter - (with-lexical-env/extend-types t-names t-types - (check-field-set!s #'(begins ...) synthed-stxs inits inits-temporaries-types))] + (with-lexical-env/extend-types temp-names init-types + (check-field-set!s #'(begins ...) synthed-stxs inits))] [_ (void)]))) ;; setter->type : Id -> Type @@ -1144,11 +1141,11 @@ [else (tc-expr/check init-val (ret init-type))]))) -;; synthesize-private-field-types : Listof Dict Hash Hash -> Listof +;; synthesize-private-field-types : Listof Dict Hash -> Listof ;; Given top-level expressions in the class, synthesize types from ;; the initialization expressions for private fields. Returns the initial ;; value expressions that were type synthesized. -(define (synthesize-private-field-types stxs locals types inits-temporaries-types) +(define (synthesize-private-field-types stxs locals types) (for/fold ([synthed-stxs null]) ([stx (in-list stxs)]) (syntax-parse stx @@ -1186,23 +1183,18 @@ (define field-names (map syntax-e (syntax-e (tr:class:def-property stx)))) (define temporary-stxs (syntax-e #'(initial-value-name ...))) (define init-types - (match (tc-expr/check #'initial-values #f) - [(tc-results: xs ) xs])) - (unless (= (length field-names) (length init-types)) - (tc-error/expr "wrong number of values: expected ~a but got ~a" - (length field-names) (length init-types))) - (define temporaries-types - (for/list - ([name (in-list field-names)] - [temp-stx (in-list temporary-stxs)] - [type (in-list init-types)]) - (define type-table-val (generalize type)) - (unless (hash-has-key? types name) - (hash-set! types name (list type-table-val))) - (cons temp-stx type-table-val))) - (hash-set! inits-temporaries-types stx - (list (map car temporaries-types) - (map cdr temporaries-types))) + ;; this gets re-checked later, so don't throw any errors yet + (match (tc-expr/check? #'initial-values #f) + [(tc-results: xs ) xs] + ;; We have to return something here so use the most conservative type + [#f (make-list (length field-names) Univ)])) + (for ([name (in-list field-names)] + [temp-stx (in-list temporary-stxs)] + [type (in-list init-types)]) + (define type-table-val (generalize type)) + (unless (hash-has-key? types name) + (hash-set! types name (list type-table-val))) + (cons temp-stx type-table-val)) (cons #'initial-values synthed-stxs)]))) ;; Syntax -> Dict Dict diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt index c28266e4..9fac9223 100644 --- a/typed-racket-test/unit-tests/class-tests.rkt +++ b/typed-racket-test/unit-tests/class-tests.rkt @@ -2073,7 +2073,7 @@ (: get-a (-> String)) (define/public (get-a) a))) (error "foo")) - #:msg #rx"expected: String.*given: Integer"] + #:msg #rx"expected: String.*given: One"] [tc-err (let () (define c% (class object% @@ -2083,7 +2083,7 @@ (: get-a (-> String)) (define/public (get-a) a))) (error "foo")) - #:msg #rx"expected: String.*given: Integer"] + #:msg #rx"expected: String.*given: One"] ;; Make sure `send` works on a recursively typed object [tc-e (let () (: o (Rec X (Object [m (-> Void)] [n (-> X Void)]))) @@ -2093,4 +2093,20 @@ (define/public (m) (void)) (define/public (n x) (void))))) (send o m)) + -Void] + ;; A test for GH issue #218. Make sure that multiple private fields + ;; are typechecked in the right context. + [tc-e (let () + (define-type-alias C% + (Class (init-field (path Path-String)))) + (: c% C%) + (define c% + (class object% + (init-field path) + (: in Input-Port) + (: out Output-Port) + (define-values (in out) + (values (open-input-file path) (open-output-file path))) + (super-new))) + (void)) -Void]))