Fix error message when polymorphic inference fails because of expected type.

Add test case.

svn: r13639

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))

collects/typed-scheme/typecheck/tc-app-unit.ss

@@ -118,26 +118,40 @@
 
 ;(trace tc-args)
 
-(define (stringify-domain dom rst drst)
+(define (stringify-domain dom rst drst [rng #f])
-  (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))])
+  (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)]
+           (format "~a~a *~a" doms-string rst rng-string)]
-          [else (stringify dom)])))
+          [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"
+     (format "~a: ~a~nArguments: ~a~n~a"
-             (stringify (map stringify-domain doms rests drests) "~n\t")
+             (if expected "Types" "Domains")
-             (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))]))
+             (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)))