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 f2387763..3bd00c28 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -953,15 +953,28 @@ (#%plain-app local-setter:id obj2:id y:id))))) #:when (free-identifier=? #'x #'y) #:when (free-identifier=? #'obj1 #'obj2) - ;; Remove wcm for checking since TR can't handle these cases - (define simplified - (syntax/loc form - (let-values (((obj1) self)) - (let-values (((x) init-val)) - (#%plain-app local-setter obj2 y))))) - (tc-expr simplified)] + ;; Only check init-val, trust that the rest is well-formed. + ;; Extracting the field type from the setter and using + ;; tc-expr/check propagates expected types better than + ;; checking the whole expression. It's also hard to extract + ;; the field type from a table since we don't know which + ;; field this setter corresponds to (except via the local + ;; binding name in the `let-values` which doesn't seem + ;; very reliable). + (define type (setter->type #'local-setter)) + (tc-expr/check #'init-val (ret type))] [_ (void)]))) +;; setter->type : Id -> Type +;; Determine the field type based on its private setter name +;; (assumption: the type environment maps this name already) +(define (setter->type id) + (define f-type (lookup-type/lexical id)) + (match f-type + [(Function: (list (arr: (list _ type) _ _ _ _))) + type] + [#f (int-err "setter->type ~a" (syntax-e id))])) + ;; check-init-arg : Id Type Syntax -> Void ;; Check the initialization of an init arg variable against the ;; expected type provided by an annotation (or the default) diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt index e83acc34..4d614c60 100644 --- a/typed-racket-test/unit-tests/class-tests.rkt +++ b/typed-racket-test/unit-tests/class-tests.rkt @@ -529,7 +529,7 @@ (: f (-> String)) (define (f) 'bad)) (error "foo")) - #:msg #rx"type mismatch.*expected: \\(-> String\\)"] + #:msg #rx"type mismatch.*expected: String"] ;; multiple names in define-values private fields [tc-e (class object% (super-new) @@ -1693,4 +1693,11 @@ [tc-e (class object% (super-new) (define/public foo (case-lambda [(str) (void)] [(sym size) (void)]))) - (-class #:method [(foo (cl->* (t:-> Univ Univ -Void) (t:-> Univ -Void)))])])) + (-class #:method [(foo (cl->* (t:-> Univ Univ -Void) (t:-> Univ -Void)))])] + ;; PR 14911 + [tc-e (class object% + (super-new) + (: bar (-> String String)) + (define bar (lambda (x) x)) + (bar "foo")) + (-class)]))