From 3b0c0fcc8c6730cff0db51178d397b967af400ff Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 May 2008 17:20:55 +0000 Subject: [PATCH] Improve error messages for polymorphic functions in apply. Fix tc-plambda when expected is #f. svn: r9596 --- collects/typed-scheme/private/infer-ops.ss | 2 +- collects/typed-scheme/private/tc-app-unit.ss | 41 +++++++++++++------ .../typed-scheme/private/tc-lambda-unit.ss | 27 ++++++++---- 3 files changed, 47 insertions(+), 23 deletions(-) diff --git a/collects/typed-scheme/private/infer-ops.ss b/collects/typed-scheme/private/infer-ops.ss index 06ba740dc3..69a3268987 100644 --- a/collects/typed-scheme/private/infer-ops.ss +++ b/collects/typed-scheme/private/infer-ops.ss @@ -326,4 +326,4 @@ ;(trace infer cgen cset-meet* subst-gen) -;(trace cgen) +;(trace infer subst-gen) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index 2cf6d9ab42..1f19cd4d6d 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -150,28 +150,43 @@ [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ..1)))) (for-each (lambda (x) (unless (not (Poly? x)) - (tc-error "Polymorphic argument ~a to polymorphic function not allowed" x))) + (tc-error "Polymorphic argument ~a to polymorphic function in apply not allowed" x))) arg-tys0) (let loop ([doms* doms] [rngs* rngs] [rests* rests]) (cond [(null? doms*) - (if (= 1 (length doms)) - (tc-error/expr - #:return (ret (Un)) - "polymorphic function domain did not match - domain was: ~a arguments were ~a" - (car doms) arg-tys0) - (tc-error/expr - #:return (ret (Un)) - "no polymorphic function domain matched - domains were: ~a arguments were ~a" - doms arg-tys0))] + (match f-ty + [(tc-result: (Poly-names: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ..1)))) + (cond + [(null? doms) (int-err "how could doms be null: ~a ~a" doms f-ty)] + [(= 1 (length doms)) + (if (car rests) + (tc-error/expr + #:return (ret (Un)) + "polymorphic function domain did not match -~ndomain was: ~a~nrest argument was: ~a~narguments were ~a~n" + (car doms) (car rests) (stringify arg-tys0)) + (tc-error/expr + #:return (ret (Un)) + "polymorphic function domain did not match -~ndomain was: ~a~narguments were ~a~n" + (car doms) (stringify arg-tys0)))] + [else + (tc-error/expr + #:return (ret (Un)) + "no polymorphic function domain matched - ~ndomains were: ~a~narguments were ~a~n" + (stringify + (for/list ([dom doms] [rest rests]) + (if rest + (format "~a rest argument: " (stringify dom) rest) + (stringify dom))) + "\n") + (stringify arg-tys0))])])] [(and (= (length (car doms*)) (length arg-tys)) - (infer vars (append (car doms*) (list (make-Listof (car rests*)))) arg-tys0 (car rngs*)) - #;(infer/list (append (car doms*) (list (make-Listof (car rests*)))) arg-tys0 vars)) + (infer vars arg-tys0 (append (car doms*) (list (make-Listof (car rests*)))) (car rngs*))) => (lambda (substitution) (let* ([s (lambda (t) (subst-all substitution t))] [new-doms* (append (map s (car doms*)) (list (make-Listof (s (car rests*)))))]) (unless (andmap subtype arg-tys0 new-doms*) - (int-err "Inconsistent substitution - arguments not subtypes"))) + (int-err "Inconsistent substitution - arguments not subtypes: ~n~a~n~a~n" arg-tys0 new-doms*))) (ret (subst-all substitution (car rngs*))))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] [(tc-result: (Poly: vars (Function: '()))) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss index 37237604a3..c2326de285 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -173,15 +173,24 @@ (define (tc/plambda form formals bodies expected) (match expected [(Poly-names: ns (and expected* (Function: _))) - (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) - (or (and p (map syntax-e (syntax->list p))) - ns))] - [literal-tvars tvars] - [new-tvars (map make-F literal-tvars)] - [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) - (tc/mono-lambda formals bodies expected*))]) - ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) - (ret (make-Poly literal-tvars ty)))] + (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) + (or (and p (map syntax-e (syntax->list p))) + ns))] + [literal-tvars tvars] + [new-tvars (map make-F literal-tvars)] + [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) + (tc/mono-lambda formals bodies expected*))]) + ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) + (ret expected))] + [#f + (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) + (map syntax-e (syntax->list p)))] + [literal-tvars tvars] + [new-tvars (map make-F literal-tvars)] + [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) + (tc/mono-lambda formals bodies #f))]) + ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) + (ret (make-Poly literal-tvars ty)))] [_ (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected)]))