From 086aac734b8f2aa179038720ebde3c4559070dc6 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 2 Oct 2014 12:21:27 -0400 Subject: [PATCH] Fix checking of (list ...) w/ union expected type Closes PR 14758 Closes PR 14747 original commit: 5138614abacb7309213e772fe3701a8c9c882f37 --- .../typed-racket/typecheck/signatures.rkt | 2 ++ .../typecheck/tc-app/tc-app-list.rkt | 6 +++--- .../typed-racket/typecheck/tc-expr-unit.rkt | 17 ++++++++++++++++ .../typed-racket/utils/tc-utils.rkt | 9 +++++++++ .../typed-racket/unit-tests/class-tests.rkt | 2 +- .../unit-tests/typecheck-tests.rkt | 20 +++++++++++++++++++ 6 files changed, 52 insertions(+), 4 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt index 44df9389..ece9c799 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt @@ -8,7 +8,9 @@ (define-signature tc-expr^ ([cond-contracted tc-expr (syntax? . -> . full-tc-results/c)] [cond-contracted tc-expr/check (syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)] + [cond-contracted tc-expr/check? (syntax? (or/c tc-results/c #f) . -> . (or/c full-tc-results/c #f))] [cond-contracted tc-expr/check/t (syntax? tc-results/c . -> . Type/c)] + [cond-contracted tc-expr/check/t? (syntax? (or/c tc-results/c #f) . -> . (or/c Type/c #f))] [cond-contracted tc-body/check (syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)] [cond-contracted tc-expr/t (syntax? . -> . Type/c)] [cond-contracted single-value ((syntax?) ((or/c tc-results/c #f)) . ->* . full-tc-results/c)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt index 6b4cf18d..252524a3 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt @@ -93,9 +93,9 @@ [_ #f])) (ret (-Tuple (for/list ([i (in-syntax #'args)] [v (in-list vs)]) - (if subst - (tc-expr/check/t i (ret (subst-all subst (make-F v)))) - (tc-expr/t i))))))) + (or (and subst + (tc-expr/check/t? i (ret (subst-all subst (make-F v))))) + (tc-expr/t i))))))) ;; special case for `list*' (pattern (list* (~between args:expr 1 +inf.0) ...) (match-let* ([(list tys ... last) (stx-map tc-expr/t #'(args ...))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index f6a44bab..749d5b92 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -76,6 +76,23 @@ (add-typeof-expr form t) (cond-check-below t expected))) +;; typecheck and return a truth value indicating a typecheck failure (#f) +;; or success (any non-#f value) +(define (tc-expr/check? form expected) + (parameterize ([current-type-error? #f]) + (with-handlers ([exn:fail:syntax? (λ (_) #f)]) + (dynamic-wind + (λ () (save-errors!)) + (λ () + (let ([result (tc-expr/check form expected)]) + (and (not (current-type-error?)) result))) + (λ () (restore-errors!)))))) + +(define (tc-expr/check/t? form expected) + (match (tc-expr/check? form expected) + [(tc-result1: t) t] + [#f #f])) + (define (explicit-fail stx msg var) (cond [(and (identifier? var) (lookup-type/lexical var #:fail (λ _ #f))) => diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt index 90f2ab48..1d644d26 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt @@ -14,6 +14,7 @@ don't depend on any other portion of the system current-orig-stx orig-module-stx expanded-module-stx + current-type-error? print-syntax? warn-unreachable? delay-errors? @@ -23,6 +24,8 @@ don't depend on any other portion of the system locate-stx warn-unreachable + save-errors! + restore-errors! reset-errors! report-first-error report-all-errors @@ -46,6 +49,10 @@ don't depend on any other portion of the system (define orig-module-stx (make-parameter #f)) (define expanded-module-stx (make-parameter #f)) +;; a parameter that represents whether a type error has occurred (#t) or +;; not (#f) in the current dynamic extent +(define current-type-error? (make-parameter #f)) + (define (stringify l [between " "]) (define (intersperse v l) (cond [(null? l) null] @@ -185,6 +192,7 @@ don't depend on any other portion of the system (unless (syntax? stx) (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) + (current-type-error? #t) (if (delay-errors?) (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) @@ -224,6 +232,7 @@ don't depend on any other portion of the system (let* ([ostx (current-orig-stx)] [ostxs (if (list? ostx) ostx (list ostx))] [stxs (map locate-stx ostxs)]) + (current-type-error? #t) ;; If this isn't original syntax, then we can get some pretty bogus error ;; messages. Note that this is from a macro expansion, so that introduced ;; vars and such don't confuse the user. 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 fa32d80f..b6b65647 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 @@ -1436,7 +1436,7 @@ (init-rest [rst : (List Symbol)]))) (make-object c% "wrong")) #:ret (ret (make-Instance (make-Class #f null null null null (-Tuple (list -Symbol))))) - #:msg #rx"expected: Symbol.*given: String"] + #:msg #rx"expected: \\(List Symbol.*given: \\(List String"] ;; PR 14408, test init-field order [tc-e (let () (define c% diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 58b0cd88..b93de79e 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -3293,6 +3293,26 @@ ;; don't produce an internal error [tc-err (let () (define x (values 1 2)) (error "dummy")) #:msg #rx"Expression should produce 1 values"] + + ;; PR 14758 + [tc-e (ann (list 'change-size 30) + (U (List 'change-family Symbol) + (List 'change-size Byte))) + (t:Un (-lst* (-val 'change-family) -Symbol) + (-lst* (-val 'change-size) -Byte))] + + ;; PR 14747 + [tc-e (let () + (define-type-alias XExpr + (U String Symbol Char + (Pairof Symbol (Pairof (Listof (List Symbol String)) (Listof XExpr))) + (Pairof Symbol (Listof XExpr)))) + (: bug XExpr) + (define bug + (let: ([elem : XExpr "some xexpr"]) + `(li ,elem))) + (void)) + -Void] ) (test-suite