diff --git a/collects/tests/typed-scheme/fail/poly-expect-error.ss b/collects/tests/typed-scheme/fail/poly-expect-error.ss new file mode 100644 index 0000000000..0259e3acfe --- /dev/null +++ b/collects/tests/typed-scheme/fail/poly-expect-error.ss @@ -0,0 +1,9 @@ +#; +(exn-pred "Boolean") +#lang typed-scheme + +(: f (All (A) (case-lambda (String -> Boolean) (A -> Boolean)))) +(define (f x) #t) + +(: x Number) +(define x (f 3)) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index ee815cbc61..dbe864f112 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -118,26 +118,40 @@ ;(trace tc-args) -(define (stringify-domain dom rst drst) - (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))]) +(define (stringify-domain dom rst drst [rng #f]) + (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] + [rng-string (if rng (format " -> ~a" rng) "")]) (cond [drst - (format "~a~a ... ~a" doms-string (car drst) (cdr drst))] + (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] [rst - (format "~a~a *" doms-string rst)] - [else (stringify dom)]))) + (format "~a~a *~a" doms-string rst rng-string)] + [else (string-append (stringify dom) rng-string)]))) -(define (domain-mismatches ty doms rests drests arg-tys tail-ty tail-bound) +(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) + (define arguments-str + (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f))) (cond [(null? doms) (int-err "How could doms be null: ~a ~a" ty)] [(= 1 (length doms)) - (format "Domain: ~a~nArguments: ~a~n" + (format "Domain: ~a~nArguments: ~a~n~a" (stringify-domain (car doms) (car rests) (car drests)) - (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))] + arguments-str + (if expected + (format "Result type: ~a~nExpected result: ~a~n" + (car rngs) expected) + ""))] [else - (format "Domains: ~a~nArguments: ~a~n" - (stringify (map stringify-domain doms rests drests) "~n\t") - (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))])) + (format "~a: ~a~nArguments: ~a~n~a" + (if expected "Types" "Domains") + (stringify (if expected + (map stringify-domain doms rests drests rngs) + (map stringify-domain doms rests drests)) + "~n\t") + arguments-str + (if expected + (format "Expected result: ~a~n" expected) + ""))])) (define (do-apply-log subst fun arg) (match* (fun arg) @@ -170,7 +184,7 @@ (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to function in apply:~n" - (domain-mismatches f-ty doms rests drests arg-tys tail-ty tail-bound))))] + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))] [(and (car rests*) (let-values ([(tail-ty tail-bound) (with-handlers ([exn:fail? (lambda _ (values #f #f))]) @@ -216,7 +230,7 @@ (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests arg-tys tail-ty tail-bound)))])] + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -268,7 +282,7 @@ (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests arg-tys tail-ty tail-bound)))])] + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -372,9 +386,9 @@ (log-result substitution) (ret (or expected (subst-all substitution rng)))))) - (poly-fail t argtypes #:name (and (identifier? f-stx) f-stx)))))])) + (poly-fail t argtypes #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) -(define (poly-fail t argtypes #:name [name #f]) +(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) (match t [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) @@ -391,7 +405,7 @@ (tc-error/expr #:return (ret (Un)) (string-append "Polymorphic " fcn-string " could not be applied to arguments:~n" - (domain-mismatches t msg-doms msg-rests msg-drests argtypes #f #f) + (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) (string-append "Type Variables: " (stringify msg-vars) "\n") "")))))])) @@ -444,7 +458,7 @@ (tc-error/expr #:return (ret (Un)) (string-append "No function domains matched in function application:\n" - (domain-mismatches t doms rests drests argtypes #f #f)))] + (domain-mismatches t doms rests drests rngs argtypes #f #f)))] [(subtypes/varargs argtypes (car doms*) (car rests*)) (when (car rests*) (printf/log "Simple varargs function application (~a)\n" (syntax->datum f-stx)))