From 81252541dcc497921ab2b78283081956bb78500d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Apr 2012 14:31:38 -0500 Subject: [PATCH] add context to blame error messages This is using the same idea that Stevie had, more than two years ago(!). Sorry for not picking up on this earlier --- collects/racket/contract/private/arrow.rkt | 365 +++++++++++---------- collects/racket/contract/private/blame.rkt | 59 +++- collects/racket/contract/private/misc.rkt | 173 ++++++---- collects/racket/contract/private/prop.rkt | 10 +- collects/racket/private/class-internal.rkt | 42 ++- collects/tests/racket/contract-test.rktl | 117 +++++++ 6 files changed, 487 insertions(+), 279 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 901c8ba62c..7b8e642dd2 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -105,27 +105,28 @@ v4 todo: (define name (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)) (define (projection wrapper) - (λ (blame) - (let* ([p-app-x (proj-x blame)] ... - [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))]) - (λ (val) - (unless (procedure? val) - (raise-blame-error blame val "expected a procedure, got ~v" val)) - (wrapper - val - (make-keyword-procedure - (λ (kwds kwd-vals . args) - #,(check-tail-contract - #'(p-app-x ...) - (list #'res-checker) - (λ (s) #`(apply values #,@s kwd-vals args)))) - (λ args - #,(check-tail-contract - #'(p-app-x ...) - (list #'res-checker) - (λ (s) #`(apply values #,@s args))))) - impersonator-prop:contracted ctc - impersonator-prop:application-mark (cons contract-key (list p-app-x ...))))))) + (λ (orig-blame) + (let ([rng-blame (blame-add-context orig-blame "the range of")]) + (let* ([p-app-x (proj-x rng-blame)] ... + [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))]) + (λ (val) + (unless (procedure? val) + (raise-blame-error orig-blame val "expected a procedure, got ~v" val)) + (wrapper + val + (make-keyword-procedure + (λ (kwds kwd-vals . args) + #,(check-tail-contract + #'(p-app-x ...) + (list #'res-checker) + (λ (s) #`(apply values #,@s kwd-vals args)))) + (λ args + #,(check-tail-contract + #'(p-app-x ...) + (list #'res-checker) + (λ (s) #`(apply values #,@s args))))) + impersonator-prop:contracted ctc + impersonator-prop:application-mark (cons contract-key (list p-app-x ...)))))))) (define ctc (if (and (chaperone-contract? rngs-x) ...) (make-chaperone-contract @@ -464,33 +465,45 @@ v4 todo: [pre (base->-pre ctc)] [post (base->-post ctc)] [mtd? (base->-mtd? ctc)]) - (λ (blame) - (let ([swapped (blame-swap blame)]) - (let ([partial-doms (map (λ (dom) (dom swapped)) doms-proj)] - [partial-optional-doms (map (λ (dom) (dom swapped)) doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng blame)) rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)]) - (define the-args (append partial-doms partial-optional-doms - partial-mandatory-kwds partial-optional-kwds - partial-ranges)) - (λ (val) - (if has-rest? - (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame) - (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame)) - (define chap/imp-func (apply func blame val the-args)) - (if post - (wrapper - val - chap/imp-func - impersonator-prop:contracted ctc) - (wrapper - val - chap/imp-func - impersonator-prop:contracted ctc - impersonator-prop:application-mark (cons contract-key - ;; is this right? - partial-ranges))))))))) + (λ (orig-blame) + (define rng-blame (blame-add-context orig-blame "the range of")) + (define swapped (blame-swap orig-blame)) + (define swapped-domain (blame-add-context swapped "the domain of")) + (define partial-doms + (for/list ([dom (in-list doms-proj)] + [n (in-naturals 1)]) + (dom (blame-add-context swapped + (format "the ~a argument of" + (n->th n)))))) + (define partial-optional-doms + (for/list ([dom (in-list doms-optional-proj)] + [n (in-naturals (+ 1 (length doms-proj)))]) + (dom (blame-add-context swapped + (format "the ~a argument of" + (n->th n)))))) + (define partial-ranges (map (λ (rng) (rng rng-blame)) rngs-proj)) + (define partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)) + (define partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)) + (define the-args (append partial-doms partial-optional-doms + partial-mandatory-kwds partial-optional-kwds + partial-ranges)) + (λ (val) + (if has-rest? + (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame) + (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame)) + (define chap/imp-func (apply func orig-blame val the-args)) + (if post + (wrapper + val + chap/imp-func + impersonator-prop:contracted ctc) + (wrapper + val + chap/imp-func + impersonator-prop:contracted ctc + impersonator-prop:application-mark (cons contract-key + ;; is this right? + partial-ranges))))))) (define (->-name ctc) (single-arrow-name-maker @@ -1169,132 +1182,133 @@ v4 todo: [else (cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (λ (blame) - (λ (val) - (if (base-->d-rest-ctc ->d-stct) - (check-procedure/more val - (base-->d-mtd? ->d-stct) - (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (base-->d-mandatory-keywords ->d-stct) - (base-->d-optional-keywords ->d-stct) - blame) - (check-procedure val - (base-->d-mtd? ->d-stct) - (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length - (base-->d-mandatory-keywords ->d-stct) - (base-->d-optional-keywords ->d-stct) - blame)) - (wrap-procedure - val - (make-keyword-procedure - (λ (kwd-args kwd-arg-vals . raw-orig-args) - (let* ([orig-args (if (base-->d-mtd? ->d-stct) - (cdr raw-orig-args) - raw-orig-args)] - [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))] - [dep-pre-args - (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (base-->d-rest-ctc ->d-stct) - (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (base-->d-pre-cond ->d-stct) - (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args) - (raise-blame-error (blame-swap blame) - val - "#:pre violation~a" - (build-values-string ", argument" dep-pre-args)))) - (apply - values - - (append - - (let ([rng (let ([rng (base-->d-range ->d-stct)]) - (cond - [(not rng) #f] - [(box? rng) - (map (λ (val) (apply val dep-pre-args)) - (unbox rng))] - [else rng]))] - [rng-underscore? (box? (base-->d-range ->d-stct))]) - (if rng - (list (λ orig-results - (let* ([range-count (length rng)] - [post-args (append orig-results raw-orig-args)] - [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] - [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count - post-args (base-->d-rest-ctc ->d-stct) - (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (base-->d-post-cond ->d-stct) - (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) + (let ([blame (blame-add-context blame "the domain of")]) + (λ (val) + (if (base-->d-rest-ctc ->d-stct) + (check-procedure/more val + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) + blame) + (check-procedure val + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) + blame)) + (wrap-procedure + val + (make-keyword-procedure + (λ (kwd-args kwd-arg-vals . raw-orig-args) + (let* ([orig-args (if (base-->d-mtd? ->d-stct) + (cdr raw-orig-args) + raw-orig-args)] + [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))] + [dep-pre-args + (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (base-->d-rest-ctc ->d-stct) + (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (base-->d-pre-cond ->d-stct) + (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args) + (raise-blame-error (blame-swap blame) + val + "#:pre violation~a" + (build-values-string ", argument" dep-pre-args)))) + (apply + values + + (append + + (let ([rng (let ([rng (base-->d-range ->d-stct)]) + (cond + [(not rng) #f] + [(box? rng) + (map (λ (val) (apply val dep-pre-args)) + (unbox rng))] + [else rng]))] + [rng-underscore? (box? (base-->d-range ->d-stct))]) + (if rng + (list (λ orig-results + (let* ([range-count (length rng)] + [post-args (append orig-results raw-orig-args)] + [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] + [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count + post-args (base-->d-rest-ctc ->d-stct) + (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (base-->d-post-cond ->d-stct) + (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) + (raise-blame-error blame + val + "#:post violation~a~a" + (build-values-string ", argument" dep-pre-args) + (build-values-string (if (null? dep-pre-args) + ", result" + "\n result") + orig-results)))) + + (unless (= range-count (length orig-results)) (raise-blame-error blame val - "#:post violation~a~a" - (build-values-string ", argument" dep-pre-args) - (build-values-string (if (null? dep-pre-args) - ", result" - "\n result") - orig-results)))) - - (unless (= range-count (length orig-results)) - (raise-blame-error blame - val - "expected ~a results, got ~a" - range-count - (length orig-results))) - (apply - values - (let loop ([results orig-results] - [result-contracts rng]) + "expected ~a results, got ~a" + range-count + (length orig-results))) + (apply + values + (let loop ([results orig-results] + [result-contracts rng]) + (cond + [(null? result-contracts) '()] + [else + (cons + (invoke-dep-ctc (car result-contracts) + (if rng-underscore? #f dep-post-args) + (car results) + blame) + (loop (cdr results) (cdr result-contracts)))])))))) + null)) + + ;; contracted keyword arguments + (let ([kwd-res (let loop ([all-kwds (base-->d-keywords ->d-stct)] + [kwd-ctcs (base-->d-keyword-ctcs ->d-stct)] + [building-kwd-args kwd-args] + [building-kwd-arg-vals kwd-arg-vals]) (cond - [(null? result-contracts) '()] - [else - (cons - (invoke-dep-ctc (car result-contracts) - (if rng-underscore? #f dep-post-args) - (car results) - blame) - (loop (cdr results) (cdr result-contracts)))])))))) - null)) - - ;; contracted keyword arguments - (let ([kwd-res (let loop ([all-kwds (base-->d-keywords ->d-stct)] - [kwd-ctcs (base-->d-keyword-ctcs ->d-stct)] - [building-kwd-args kwd-args] - [building-kwd-arg-vals kwd-arg-vals]) - (cond - [(or (null? building-kwd-args) (null? all-kwds)) '()] - [else (if (eq? (car all-kwds) - (car building-kwd-args)) - (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) - (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) - (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))]) - (if (null? kwd-res) null (list kwd-res))) - - - ;; this parameter (if necc.) - (if (base-->d-mtd? ->d-stct) - (list (car raw-orig-args)) - '()) - - ;; contracted ordinary arguments - (let loop ([args orig-args] - [non-kwd-ctcs (append (base-->d-mandatory-dom-ctcs ->d-stct) - (base-->d-optional-dom-ctcs ->d-stct))]) - (cond - [(null? args) - (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) - '())] - [(null? non-kwd-ctcs) - (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) - - ;; ran out of arguments, but don't have a rest parameter. - ;; procedure-reduce-arity (or whatever the new thing is - ;; going to be called) should ensure this doesn't happen. - (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) - (loop (cdr args) - (cdr non-kwd-ctcs)))]))))))) - impersonator-prop:contracted ->d-stct))))) + [(or (null? building-kwd-args) (null? all-kwds)) '()] + [else (if (eq? (car all-kwds) + (car building-kwd-args)) + (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) + (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) + (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))]) + (if (null? kwd-res) null (list kwd-res))) + + + ;; this parameter (if necc.) + (if (base-->d-mtd? ->d-stct) + (list (car raw-orig-args)) + '()) + + ;; contracted ordinary arguments + (let loop ([args orig-args] + [non-kwd-ctcs (append (base-->d-mandatory-dom-ctcs ->d-stct) + (base-->d-optional-dom-ctcs ->d-stct))]) + (cond + [(null? args) + (if (base-->d-rest-ctc ->d-stct) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) + '())] + [(null? non-kwd-ctcs) + (if (base-->d-rest-ctc ->d-stct) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) + + ;; ran out of arguments, but don't have a rest parameter. + ;; procedure-reduce-arity (or whatever the new thing is + ;; going to be called) should ensure this doesn't happen. + (error 'shouldnt\ happen))] + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) + (loop (cdr args) + (cdr non-kwd-ctcs)))]))))))) + impersonator-prop:contracted ->d-stct)))))) (define (build-values-string desc dep-pre-args) (cond @@ -1604,8 +1618,10 @@ v4 todo: [rst-ctcs (base-case->-rst-ctcs ctc)] [specs (base-case->-specs ctc)]) (λ (blame) - (let ([projs (append (map (λ (f) (f (blame-swap blame))) dom-ctcs) - (map (λ (f) (f blame)) rng-ctcs))] + (define dom-blame (blame-add-context (blame-swap blame) "the domain of")) + (define rng-blame (blame-add-context blame "the range of")) + (let ([projs (append (map (λ (f) (f dom-blame)) dom-ctcs) + (map (λ (f) (f rng-blame)) rng-ctcs))] [chk (λ (val mtd?) (cond @@ -1915,7 +1931,8 @@ v4 todo: (define (bad-number-of-results blame val rng-len args) (define num-values (length args)) - (raise-blame-error blame val + (raise-blame-error (blame-add-context blame "the range of") + val "expected ~a value~a, returned ~a value~a" rng-len (if (= rng-len 1) "" "s") num-values (if (= num-values 1) "" "s"))) diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index 65cbd6d540..a576c14221 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -2,7 +2,7 @@ (require syntax/srcloc racket/pretty setup/path-to-relative) (provide blame? - make-blame + (rename-out [-make-blame make-blame]) blame-source blame-positive blame-negative @@ -12,7 +12,9 @@ blame-swapped? blame-swap blame-replace-negative ;; used for indy blame - + blame-add-context + blame-context + raise-blame-error current-blame-format (struct-out exn:fail:contract:blame)) @@ -34,10 +36,21 @@ (hash/recur (blame-original? b)))) (define-struct blame - [source value build-name positive negative original?] + [source value build-name positive negative original? context] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) +(define -make-blame + (let ([make-blame + (λ (source value build-name positive negative original?) + (make-blame source value build-name positive negative original? '()))]) + make-blame)) + +(define (blame-add-context b s) + (struct-copy + blame b + [context (cons s (blame-context b))])) + (define (blame-contract b) ((blame-build-name b))) (define (blame-swap b) @@ -67,17 +80,33 @@ (let* ([source-message (source-location->string (blame-source b))] [positive-message (show/display (convert-blame-party (blame-positive b)))] - [contract-message (format " contract: ~a" (show/write (blame-contract b)))] - [contract-message+at (if (regexp-match #rx"\n$" contract-message) - (string-append contract-message - (if (string=? source-message "") - "" - (format " at: ~a" source-message))) - (string-append contract-message - "\n" - (if (string=? source-message "") - "" - (format " at: ~a" source-message))))]) + [context-message (apply string-append + (for/list ([context (in-list (blame-context b))] + [n (in-naturals)]) + (format (if (zero? n) + " in: ~a\n" + " ~a\n") + context)))] + [the-contract-str (show/write (blame-contract b))] + [contract-message (string-append (if (regexp-match #rx"\n" the-contract-str) + (string-append (regexp-replace #rx"\n$" context-message "") + the-contract-str) + (string-append context-message + (format " ~a" the-contract-str))))] + [contract-message+at + (regexp-replace + #rx"^\n" + (if (regexp-match #rx"\n$" contract-message) + (string-append contract-message + (if (string=? source-message "") + "" + (format " at: ~a" source-message))) + (string-append contract-message + "\n" + (if (string=? source-message "") + "" + (format " at: ~a" source-message)))) + "")]) ;; use (regexp-match #rx"\n" ...) to find out if show/display decided that this ;; is a multiple-line message and adjust surrounding formatting accordingly (cond @@ -153,7 +182,7 @@ (define (show-line-break line port len cols) (newline port) (if line - (begin (display " " port) 4) + (begin (display " " port) 6) 0)) (define current-blame-format diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index b81094248a..dfed15ee6c 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -44,7 +44,8 @@ flat-named-contract contract-projection - contract-name) + contract-name + n->th) (define-syntax (flat-rec-contract stx) (syntax-case stx () @@ -146,11 +147,12 @@ (let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))] [pred (single-or/c-pred ctc)]) (λ (blame) - (let ([partial-contract (c-proc blame)]) - (λ (val) - (cond - [(pred val) val] - [else (partial-contract val)])))))) + (define partial-contract + (c-proc (blame-add-context blame "a disjunct of"))) + (λ (val) + (cond + [(pred val) val] + [else (partial-contract val)]))))) (define (single-or/c-name ctc) (apply build-compound-type-name @@ -199,42 +201,45 @@ [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)] [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]) (λ (blame) - (let ([partial-contracts (map (λ (c-proc) (c-proc blame)) c-procs)]) - (λ (val) - (cond - [(ormap (λ (pred) (pred val)) predicates) - val] - [else - (let loop ([checks first-order-checks] - [procs partial-contracts] - [contracts ho-contracts] - [candidate-proc #f] - [candidate-contract #f]) - (cond - [(null? checks) - (if candidate-proc - (candidate-proc val) - (raise-blame-error blame val - "none of the branches of the or/c matched, given ~e" - val))] - [((car checks) val) - (if candidate-proc - (raise-blame-error blame val - "two of the clauses in the or/c might both match: ~s and ~s, given ~e" - (contract-name candidate-contract) - (contract-name (car contracts)) - val) - (loop (cdr checks) - (cdr procs) - (cdr contracts) - (car procs) - (car contracts)))] - [else - (loop (cdr checks) - (cdr procs) - (cdr contracts) - candidate-proc - candidate-contract)]))])))))) + (define disj-blame (blame-add-context blame "a disjunct of")) + (define partial-contracts + (for/list ([c-proc (in-list c-procs)]) + (c-proc disj-blame))) + (λ (val) + (cond + [(ormap (λ (pred) (pred val)) predicates) + val] + [else + (let loop ([checks first-order-checks] + [procs partial-contracts] + [contracts ho-contracts] + [candidate-proc #f] + [candidate-contract #f]) + (cond + [(null? checks) + (if candidate-proc + (candidate-proc val) + (raise-blame-error blame val + "none of the branches of the or/c matched, given ~e" + val))] + [((car checks) val) + (if candidate-proc + (raise-blame-error blame val + "two of the clauses in the or/c might both match: ~s and ~s, given ~e" + (contract-name candidate-contract) + (contract-name (car contracts)) + val) + (loop (cdr checks) + (cdr procs) + (cdr contracts) + (car procs) + (car contracts)))] + [else + (loop (cdr checks) + (cdr procs) + (cdr contracts) + candidate-proc + candidate-contract)]))]))))) (define (multi-or/c-name ctc) (apply build-compound-type-name @@ -336,10 +341,13 @@ (define (and-proj ctc) (let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))]) (lambda (blame) - (let ([projs (map (λ (c) (c blame)) mk-pos-projs)]) - (for/fold ([proj (car projs)]) - ([p (in-list (cdr projs))]) - (λ (v) (p (proj v)))))))) + (define projs + (for/list ([c (in-list mk-pos-projs)] + [n (in-naturals 1)]) + (c (blame-add-context blame (format "the ~a conjunct of" (n->th n)))))) + (for/fold ([proj (car projs)]) + ([p (in-list (cdr projs))]) + (λ (v) (p (proj v))))))) (define (first-order-and-proj ctc) (λ (blame) @@ -630,7 +638,7 @@ (for/and ([v (in-list x)]) (contract-first-order-passes? ctc v)))) (define ((ho-check check-all) blame) - (let ([p-app (proj blame)]) + (let ([p-app (proj (blame-add-context blame "an element of"))]) (λ (val) (unless (predicate? val) (raise-blame-error blame val @@ -675,8 +683,8 @@ (contract-first-order-passes? ctc-car (car v)) (contract-first-order-passes? ctc-cdr (cdr v)))) (define ((ho-check combine) blame) - (let ([car-p (car-proj blame)] - [cdr-p (cdr-proj blame)]) + (let ([car-p (car-proj (blame-add-context blame "the car of"))] + [cdr-p (cdr-proj (blame-add-context blame "the cdr of"))]) (λ (v) (unless (pair? v) (raise-blame-error blame v "expected , given: ~e" v)) @@ -729,41 +737,53 @@ #:first-order list/c-first-order #:projection (lambda (c) - (lambda (b) + (lambda (blame) (lambda (x) (unless (list? x) - (raise-blame-error b x "expected a list, got: ~e" x)) + (raise-blame-error blame x "expected a list, got: ~e" x)) (let* ([args (generic-list/c-args c)] [expected (length args)] [actual (length x)]) (unless (= actual expected) (raise-blame-error - b x + blame x "expected a list of ~a elements, but got ~a elements in: ~e" expected actual x)) - (for ([arg/c (in-list args)] [v (in-list x)]) - (((contract-projection arg/c) b) v)) + (for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)]) + (((contract-projection arg/c) + (add-list-context blame i)) + v)) x)))))) (define (list/c-chaperone/other-projection c) (define args (map contract-projection (generic-list/c-args c))) (define expected (length args)) - (λ (b) - (define projs (for/list ([arg/c (in-list args)]) - (arg/c b))) + (λ (blame) + (define projs (for/list ([arg/c (in-list args)] + [i (in-naturals 1)]) + (arg/c (add-list-context blame i)))) (λ (x) (unless (list? x) - (raise-blame-error b x "expected a list, got: ~e" x)) + (raise-blame-error blame x "expected a list, got: ~e" x)) (define actual (length x)) (unless (= actual expected) (raise-blame-error - b x + blame x "expected a list of ~a elements, but got ~a elements in: ~e" expected actual x)) (for/list ([item (in-list x)] [proj (in-list projs)]) (proj item))))) +(define (add-list-context blame i) + (blame-add-context blame (format "the ~a~a element of" + i + (case (modulo i 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [else "th"])))) + (struct chaperone-list/c generic-list/c () #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) @@ -796,7 +816,7 @@ #:name (build-compound-type-name 'promise/c ctc) #:projection (λ (blame) - (let ([p-app (ctc-proc blame)]) + (let ([p-app (ctc-proc (blame-add-context blame "the promise from"))]) (λ (val) (unless (promise? val) (raise-blame-error @@ -818,17 +838,18 @@ (λ (ctc) (let ([c-proc (contract-projection (parameter/c-ctc ctc))]) (λ (blame) - (let ([partial-neg-contract (c-proc (blame-swap blame))] - [partial-pos-contract (c-proc blame)]) - (λ (val) - (cond - [(parameter? val) - (make-derived-parameter - val - partial-neg-contract - partial-pos-contract)] - [else - (raise-blame-error blame val "expected a parameter")])))))) + (define blame/c (blame-add-context blame "the parameter of")) + (define partial-neg-contract (c-proc (blame-swap blame/c))) + (define partial-pos-contract (c-proc blame/c)) + (λ (val) + (cond + [(parameter? val) + (make-derived-parameter + val + partial-neg-contract + partial-pos-contract)] + [else + (raise-blame-error blame val "expected a parameter")]))))) #:name (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))) @@ -970,3 +991,13 @@ (integer? x) (exact? x) (x . >= . 0))))) + +(define (n->th n) + (string-append + (number->string n) + (case (modulo n 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [else "th"]))) + diff --git a/collects/racket/contract/private/prop.rkt b/collects/racket/contract/private/prop.rkt index 2d133334b0..096e410631 100644 --- a/collects/racket/contract/private/prop.rkt +++ b/collects/racket/contract/private/prop.rkt @@ -246,10 +246,12 @@ (define ((get-first-order-projection get-name get-first-order) c) (first-order-projection (get-name c) (get-first-order c))) -(define (((first-order-projection name first-order) b) x) - (if (first-order x) - x - (raise-blame-error b x "expected: ~s, given: ~e" name x))) +(define (first-order-projection name first-order) + (λ (b) + (λ (x) + (if (first-order x) + x + (raise-blame-error b x "expected: ~s, given: ~e" name x))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 6f71cb8b3b..ee627d507c 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2777,9 +2777,10 @@ (for ([m (in-list (class/c-methods ctc))] [c (in-list (class/c-method-contracts ctc))]) (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! methods i (make-method (p (vector-ref methods i)) m)))))) + (define i (hash-ref method-ht m)) + (define mp (vector-ref methods i)) + (define p ((contract-projection c) (blame-add-method-context blame mp))) + (vector-set! methods i (make-method (p mp) m))))) ;; Handle super contracts (unless (null? (class/c-supers ctc)) @@ -2789,9 +2790,10 @@ (for ([m (in-list (class/c-supers ctc))] [c (in-list (class/c-super-contracts ctc))]) (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! super-methods i (make-method (p (vector-ref super-methods i)) m)))))) + (define i (hash-ref method-ht m)) + (define mp (vector-ref super-methods i)) + (define p ((contract-projection c) (blame-add-method-context blame mp))) + (vector-set! super-methods i (make-method (p mp) m))))) ;; Add inner projections (unless (null? (class/c-inners ctc)) @@ -2799,10 +2801,10 @@ (for ([m (in-list (class/c-inners ctc))] [c (in-list (class/c-inner-contracts ctc))]) (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) bswap)] - [old-proj (vector-ref inner-projs i)]) - (vector-set! inner-projs i (λ (v) (old-proj (p v)))))))) + (define i (hash-ref method-ht m)) + (define old-proj (vector-ref inner-projs i)) + (define p ((contract-projection c) (blame-add-method-context bswap old-proj))) + (vector-set! inner-projs i (λ (v) (old-proj (p v))))))) ;; Handle both internal and external field contracts (unless no-field-ctcs? @@ -2810,8 +2812,8 @@ [c (in-list (class/c-field-contracts ctc))]) (when c (let ([fi (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bswap)]) + [p-pos ((contract-projection c) (blame-add-context blame (format "the ~a field in" f)))] + [p-neg ((contract-projection c) (blame-add-context bswap (format "the ~a field in" f)))]) (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))) (for ([f (in-list (class/c-inherit-fields ctc))] [c (in-list (class/c-inherit-field-contracts ctc))]) @@ -2861,7 +2863,7 @@ [c (in-list (class/c-override-contracts ctc))]) (when c (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) bswap)] + [p ((contract-projection c) (blame-add-method-context bswap i))] [old-idx (vector-ref old-idxs i)] [proj-vec (vector-ref dynamic-projs i)] [old-proj (vector-ref proj-vec old-idx)]) @@ -2878,7 +2880,7 @@ (class/c-augride-contracts ctc)))]) (when c (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)] + [p ((contract-projection c) (blame-add-method-context blame i))] [old-idx (vector-ref old-idxs i)] [new-idx (vector-ref dynamic-idxs i)] [proj-vec (vector-ref dynamic-projs i)] @@ -2895,7 +2897,7 @@ [c (in-list (class/c-inherit-contracts ctc))]) (when c (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)] + [p ((contract-projection c) (blame-add-method-context blame i))] [new-idx (vector-ref dynamic-idxs i)] [int-vec (vector-ref int-methods i)]) (vector-set! int-vec new-idx @@ -2961,6 +2963,16 @@ c))))) +(define (blame-add-method-context blame method-proc) + (define name (object-name method-proc)) + (cond + [name + ;; the procedure name of a method has ' method in ...' in it; trim that away + (define method-name (regexp-replace #rx" method in .*%.?$" (symbol->string name) "")) + (blame-add-context blame (format "the ~a method in" method-name))] + [else + (blame-add-context blame "an unnamed method in")])) + (define-struct class/c (methods method-contracts fields field-contracts inits init-contracts inherits inherit-contracts inherit-fields inherit-field-contracts diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index f96249dbd4..618e9ee778 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -11276,6 +11276,123 @@ so that propagation occurs. values)]) ((car s) 1))) + +; +; +; +; +; ; ; +; ;;; ;;; +; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;; ;;;; +; ;;;;; ;;;;; ;;;;;;; ;;;; ;; ;;; ;; ;; ;;;; +; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; +; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; +; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;;;; ;; ;; ;;;; +; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; +; +; +; +; + + (contract-eval '(define (extract-context-lines thunk num) + (define str + (with-handlers ((exn:fail:contract:blame? exn-message)) + (thunk) + "didn't raise an exception")) + (define lines + (regexp-split + #rx"\n " + (regexp-replace #rx"(.*)\n in: " str ""))) + (for/list ([answer-count (in-range num)] + [msg-str (in-list lines)]) + msg-str))) + + (ctest '("the cdr of" "the 1st argument of") + extract-context-lines + (λ () ((contract (-> (cons/c integer? boolean?) integer? integer?) + (λ (x y) x) + 'pos + 'neg) + (cons 1 2) 1)) + 2) + + (ctest '("the 3rd element of" "the 2nd argument of") + extract-context-lines + (λ () ((contract (-> integer? (list/c integer? integer? boolean?) integer?) + (λ (x y) x) + 'pos + 'neg) + 1 (list 1 2 3))) + 2) + + (ctest '("the range of" "the 4th element of") + extract-context-lines + (λ () ((cadddr (contract (list/c integer? integer? boolean? (-> number? number?)) + (list 1 2 #f (λ (x) #f)) + 'pos + 'neg)) + 1)) + 2) + + (ctest '("a disjunct of") + extract-context-lines + (λ () (contract (or/c 1 (-> number? number?)) + 3 + 'pos + 'neg)) + 1) + + (ctest '("the range of" "a disjunct of") + extract-context-lines + (λ () ((contract (or/c 1 (-> number? number?) (-> number? boolean? number?)) + (λ (x) #f) + 'pos + 'neg) + 1)) + 2) + + (ctest '("the 2nd conjunct of") + extract-context-lines + (λ () (contract (and/c procedure? (-> integer? integer?)) + (λ (x y) 1) + 'pos + 'neg)) + 1) + + (ctest '("an element of") + extract-context-lines + (λ () (contract (listof number?) + (list #f) + 'pos + 'neg)) + 1) + + (ctest '("the promise from") + extract-context-lines + (λ () (force (contract (promise/c number?) + (delay #f) + 'pos + 'neg))) + 1) + + (ctest '("the parameter of") + extract-context-lines + (λ () ((contract (parameter/c number?) + (make-parameter #f) + 'pos + 'neg))) + 1) + (ctest '("the parameter of") + extract-context-lines + (λ () ((contract (parameter/c number?) + (make-parameter 1) + 'pos + 'neg) + #f)) + 1) + + ; ; ;