From db0046101cb8b75e56215b4528d280894c59a36d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 7 Oct 2010 17:19:27 -0400 Subject: [PATCH] Improved TR's error messages when all domains but one have been eliminated. --- .../typed-scheme/fail/dead-substruct.rkt | 2 +- .../typed-scheme/typecheck/tc-app-helper.rkt | 196 ++++++++++++------ collects/typed-scheme/typecheck/tc-app.rkt | 20 +- collects/typed-scheme/typecheck/tc-apply.rkt | 47 +++-- collects/typed-scheme/typecheck/tc-funapp.rkt | 54 +---- 5 files changed, 186 insertions(+), 133 deletions(-) diff --git a/collects/tests/typed-scheme/fail/dead-substruct.rkt b/collects/tests/typed-scheme/fail/dead-substruct.rkt index eed75288d5..2e79f4aecd 100644 --- a/collects/tests/typed-scheme/fail/dead-substruct.rkt +++ b/collects/tests/typed-scheme/fail/dead-substruct.rkt @@ -1,5 +1,5 @@ #; -(exn-pred 1) +(exn-pred 2) #lang typed/scheme (define-struct: parent ((x : Integer))) diff --git a/collects/typed-scheme/typecheck/tc-app-helper.rkt b/collects/typed-scheme/typecheck/tc-app-helper.rkt index 36fcfd06ef..9d68edc365 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.rkt +++ b/collects/typed-scheme/typecheck/tc-app-helper.rkt @@ -1,11 +1,54 @@ #lang scheme/base -(require "../utils/utils.rkt" racket/match unstable/list +(require "../utils/utils.rkt" racket/match unstable/list unstable/sequence (only-in srfi/1 unzip4) (only-in racket/list make-list) - (utils tc-utils) (rep type-rep) (types utils union abbrev subtype)) + (prefix-in c: racket/contract) + "check-below.rkt" "tc-subst.rkt" + (utils tc-utils) + (rep type-rep object-rep) + (types utils union abbrev subtype)) (provide (all-defined-out)) + +;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? +(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) + ((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?) + (match* (ftype0 argtys) + ;; we check that all kw args are optional + [((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...))) + (list (tc-result1: t-a phi-a o-a) ...)) + (when check? + (cond [(and (not rest) (not (= (length dom) (length t-a)))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] + [(and rest (< (length t-a) (length dom))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) + (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] + [a (in-list (syntax->list args-stx))] + [arg-t (in-list t-a)]) + (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) + (let* ([dom-count (length dom)] + [arg-count (+ dom-count (if rest 1 0) (length kws))]) + (let-values + ([(o-a t-a) (for/lists (os ts) + ([nm (in-range arg-count)] + [oa (in-sequence-forever (in-list o-a) (make-Empty))] + [ta (in-sequence-forever (in-list t-a) (Un))]) + (values (if (>= nm dom-count) (make-Empty) oa) + ta))]) + (define-values (t-r f-r o-r) + (for/lists (t-r f-r o-r) + ([r (in-list results)]) + (open-Result r o-a t-a))) + (ret t-r f-r o-r)))] + [((arr: _ _ _ drest '()) _) + (int-err "funapp with drest args ~a ~a NYI" drest argtys)] + [((arr: _ _ _ _ kws) _) + (int-err "funapp with keyword args ~a NYI" kws)])) + + (define (make-printable t) (match t [(tc-result1: t) t] @@ -21,8 +64,17 @@ (format "~a~a *~a" doms-string rst rng-string)] [else (string-append (stringify (map make-printable dom)) rng-string)]))) -(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound - #:expected [expected #f]) +;; Generates error messages when operand types don't match operator domains. +(d/c (domain-mismatches f-stx args-stx ty doms rests drests rngs arg-tys tail-ty tail-bound + #:expected [expected #f] #:return [return (make-Union null)] + #:msg-thunk [msg-thunk (lambda (dom) dom)]) + ((syntax? syntax? Type/c (c:listof (c:listof Type/c)) (c:listof (c:or/c #f Type/c)) + (c:listof (c:or/c #f (c:cons/c Type/c (c:or/c c:natural-number/c symbol?)))) + (c:listof (c:or/c Values? ValuesDots?)) (c:listof tc-results?) (c:or/c #f Type/c) c:any/c) + (#:expected (c:or/c #f tc-results?) #:return tc-results? + #:msg-thunk (c:-> string? string?)) + . c:->* . tc-results?) + (define arguments-str (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) @@ -31,52 +83,71 @@ [(null? doms) (int-err "How could doms be null: ~a ~a" ty)] [(and (= 1 (length doms)) (not (car rests)) (not (car drests)) (not tail-ty) (not tail-bound)) - (apply string-append - (if (not (= (length (car doms)) (length arg-tys))) - (format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys)) - "") - (append - (for/list ([dom-t (in-list (extend arg-tys (car doms) #f))] - [arg-t (in-list (extend (car doms) arg-tys #f))] - [i (in-naturals 1)]) - (let ([dom-t (or dom-t "-none-")] - [arg-t (or arg-t "-none-")]) - (format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t)))) - (list - (if expected - (format "\nResult type: ~a\nExpected result: ~a\n" - (car rngs) (make-printable expected)) - ""))))] + (tc-error/expr + #:return return + (msg-thunk + (apply string-append + (if (not (= (length (car doms)) (length arg-tys))) + (format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys)) + "") + (append + (for/list ([dom-t (in-list (extend arg-tys (car doms) #f))] + [arg-t (in-list (extend (car doms) arg-tys #f))] + [i (in-naturals 1)]) + (let ([dom-t (or dom-t "-none-")] + [arg-t (or arg-t "-none-")]) + (format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t)))) + (list + (if expected + (format "\nResult type: ~a\nExpected result: ~a\n" + (car rngs) (make-printable expected)) + ""))))))] [(= 1 (length doms)) - (string-append - "Domain: " - (stringify-domain (car doms) (car rests) (car drests)) - "\nArguments: " - arguments-str - "\n" - (if expected - (format "Result type: ~a\nExpected result: ~a\n" - (car rngs) (make-printable expected)) - ""))] + (tc-error/expr + #:return return + (msg-thunk + (string-append + "Domain: " + (stringify-domain (car doms) (car rests) (car drests)) + "\nArguments: " + arguments-str + "\n" + (if expected + (format "Result type: ~a\nExpected result: ~a\n" + (car rngs) (make-printable expected)) + ""))))] [else (let ([label (if expected "Types: " "Domains: ")] [nl+spc (if expected "\n " "\n ")]) ;; we restrict the domains shown in the error messages to those that ;; are useful (let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)]) - (let ([pdoms (map make-printable pdoms)]) - (string-append - label - (stringify (if expected - (map stringify-domain pdoms rests drests rngs) - (map stringify-domain pdoms rests drests)) - nl+spc) - "\nArguments: " - arguments-str - "\n" - (if expected - (format "Expected result: ~a\n" (make-printable expected)) - "")))))])) + (if (= (length pdoms) 1) + ;; if we narrowed down the possible cases to a single one, have + ;; tc/funapp1 generate a better error message + (begin (tc/funapp1 f-stx args-stx + (make-arr (car pdoms) (car rngs) + (car rests) (car drests) null) + arg-tys expected) + return) + ;; if not, print the message as usual + (let* ([pdoms (map make-printable pdoms)] + [err-doms + (string-append + label + (stringify (if expected + (map stringify-domain pdoms rests drests rngs) + (map stringify-domain pdoms rests drests)) + nl+spc) + "\nArguments: " + arguments-str + "\n" + (if expected + (format "Expected result: ~a\n" (make-printable expected)) + ""))]) + (tc-error/expr + #:return return + (msg-thunk err-doms))))))])) ; generate message ;; to avoid long and confusing error messages, in the case of functions with @@ -177,7 +248,8 @@ (let ([fun-tys-ret-any (map (match-lambda [(Function: (list (arr: dom _ rest drest _))) - (make-Function (list (make-arr dom Univ rest drest null)))]) + (make-Function (list (make-arr dom (-values (list Univ)) + rest drest null)))]) candidates)]) (let loop ([cases fun-tys-ret-any] [parts parts-acc] @@ -200,7 +272,7 @@ orig (reverse parts-acc))))))))))) -(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) +(define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f]) (match t [(or (Poly-names: msg-vars @@ -218,13 +290,16 @@ "Could not infer types for applying polymorphic " fcn-string "\n")) - (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 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") - "")))))] + (domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests + msg-rngs argtypes #f #f #:expected expected + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:\n" + dom + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + ""))))))] [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))) (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))) (let ([fcn-string (if name @@ -237,10 +312,13 @@ "Could not infer types for applying polymorphic " fcn-string "\n")) - (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 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") - "")))))])) + (domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests + msg-rngs argtypes #f #f #:expected expected + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:\n" + dom + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + ""))))))])) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 3a9322a8f4..96d546e7e9 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -137,15 +137,19 @@ (match a [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))]) (if (null? new-arities) - (tc-error/expr + (domain-mismatches + (car (syntax-e form)) (cdr (syntax-e form)) + arities doms rests drests rngs + (map tc-expr (syntax->list pos-args)) + #f #f #:expected expected #:return (or expected (ret (Un))) - (string-append "No function domains matched in function application:\n" - (domain-mismatches arities doms rests drests rngs - (map tc-expr (syntax->list pos-args)) - #f #f #:expected expected))) - (tc/funapp (car (syntax-e form)) kw-args - (ret (make-Function new-arities)) - (map tc-expr (syntax->list pos-args)) expected)))])) + #:msg-thunk + (lambda (dom) + (string-append "No function domains matched in function application:\n" + dom))) + (tc/funapp (car (syntax-e form)) kw-args + (ret (make-Function new-arities)) + (map tc-expr (syntax->list pos-args)) expected)))])) (define (type->list t) (match t diff --git a/collects/typed-scheme/typecheck/tc-apply.rkt b/collects/typed-scheme/typecheck/tc-apply.rkt index 99400ff338..2c832ed0b1 100644 --- a/collects/typed-scheme/typecheck/tc-apply.rkt +++ b/collects/typed-scheme/typecheck/tc-apply.rkt @@ -40,21 +40,24 @@ (match f-ty ;; apply of simple function - [(tc-result1: (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...))) + [(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...)))) ;; special case for (case-lambda) (when (null? doms) (tc-error/expr #:return (ret (Un)) "empty case-lambda given as argument to apply")) - (match-let ([arg-tys (map tc-expr/t fixed-args)] - [(tc-result1: tail-ty) (single-value tail)]) + (match-let* ([arg-tres (map tc-expr fixed-args)] + [arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] + [(tc-result1: tail-ty) (single-value tail)]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond ;; we've run out of cases to try, so error out [(null? doms*) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to function in apply:\n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty #f)))] + (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to function in apply:\n" + dom)))] ;; this case of the function type has a rest argument [(and (car rests*) ;; check that the tail expression is a subtype of the rest argument @@ -76,7 +79,8 @@ [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] ;; apply of simple polymorphic function [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + (let*-values ([(arg-tres) (map tc-expr fixed-args)] + [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [(tail-ty tail-bound) (match (tc-expr/t tail) [(ListDots: tail-ty tail-bound) (values tail-ty tail-bound)] @@ -84,11 +88,13 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:\n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) + (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to polymorphic function in apply:\n" + dom)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -129,7 +135,8 @@ "Function has no cases")] [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + (let*-values ([(arg-tres) (map tc-expr fixed-args)] + [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [(tail-ty tail-bound) (match (tc-expr/t tail) [(ListDots: tail-ty tail-bound) (values tail-ty tail-bound)] @@ -138,11 +145,13 @@ (define (finish substitution) (do-ret (subst-all substitution (car rngs*)))) (cond [(null? doms*) (match f-ty - [(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:\n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + [(tc-result1: (and t (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) + (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to polymorphic function in apply:\n" + dom)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-scheme/typecheck/tc-funapp.rkt index 7531f8aadd..48e5363ef4 100644 --- a/collects/typed-scheme/typecheck/tc-funapp.rkt +++ b/collects/typed-scheme/typecheck/tc-funapp.rkt @@ -3,9 +3,8 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer]) "signatures.rkt" "tc-metafunctions.rkt" "tc-app-helper.rkt" "find-annotation.rkt" - "tc-subst.rkt" "check-below.rkt" (prefix-in c: racket/contract) - syntax/parse racket/match racket/list unstable/sequence + syntax/parse racket/match racket/list ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy racket/bool racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) @@ -16,7 +15,7 @@ (types utils abbrev union subtype resolve convenience type-table substitute) (utils tc-utils) (except-in (env type-env-structs tvar-env index-env) extend) - (rep type-rep filter-rep object-rep rep-utils) + (rep type-rep filter-rep rep-utils) (r:infer infer) '#%paramz (for-template @@ -37,7 +36,7 @@ (let ([substitution (infer vars ... a)]) (and substitution (tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f)))) - (poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) + (poly-fail f-stx args-stx t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) (d/c (tc/funapp f-stx args-stx ftype0 argtys expected) (syntax? syntax? tc-results? (c:listof tc-results?) (c:or/c #f tc-results?) . c:-> . tc-results?) @@ -55,10 +54,11 @@ ;; we call the separate function so that we get the appropriate filters/objects (tc/funapp1 f-stx args-stx a argtys expected #:check #f)) ;; if nothing matched, error - (tc-error/expr - #:return (or expected (ret (Un))) - (string-append "No function domains matched in function application:\n" - (domain-mismatches t doms rests drests rngs argtys-t #f #f #:expected expected))))] + (domain-mismatches f-stx args-stx t doms rests drests rngs argtys #f #f + #:expected expected #:return (or expected (ret (Un))) + #:msg-thunk (lambda (dom) + (string-append "No function domains matched in function application:\n" + dom))))] ;; any kind of dotted polymorphic function without mandatory keyword args [((tc-result1: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) @@ -127,41 +127,3 @@ [((tc-result1: f-ty) _) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)])) - - -;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? -(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) - ((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?) - (match* (ftype0 argtys) - ;; we check that all kw args are optional - [((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...))) - (list (tc-result1: t-a phi-a o-a) ...)) - (when check? - (cond [(and (not rest) (not (= (length dom) (length t-a)))) - (tc-error/expr #:return (ret t-r) - "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] - [(and rest (< (length t-a) (length dom))) - (tc-error/expr #:return (ret t-r) - "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) - (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] - [a (in-list (syntax->list args-stx))] - [arg-t (in-list t-a)]) - (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) - (let* ([dom-count (length dom)] - [arg-count (+ dom-count (if rest 1 0) (length kws))]) - (let-values - ([(o-a t-a) (for/lists (os ts) - ([nm (in-range arg-count)] - [oa (in-sequence-forever (in-list o-a) (make-Empty))] - [ta (in-sequence-forever (in-list t-a) (Un))]) - (values (if (>= nm dom-count) (make-Empty) oa) - ta))]) - (define-values (t-r f-r o-r) - (for/lists (t-r f-r o-r) - ([r (in-list results)]) - (open-Result r o-a t-a))) - (ret t-r f-r o-r)))] - [((arr: _ _ _ drest '()) _) - (int-err "funapp with drest args ~a ~a NYI" drest argtys)] - [((arr: _ _ _ _ kws) _) - (int-err "funapp with keyword args ~a NYI" kws)]))