suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
Add test case.

svn: r13639
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-16 02:12:13 +00:00
parent 74f88bde68
commit 02efc28dff
2 changed files with 41 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/tests/typed-scheme/fail/poly-expect-error.ss Normal file
View File

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

50
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

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