From 3fceae27152c06906fec247fcb762c5133e8da13 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 15 May 2012 17:49:47 -0500 Subject: [PATCH] adjusted the contract error messages so that the words expected/promised are switched in and out based on the sense of the blame (similar to a recent change that made given/produced swap in and out) --- collects/racket/contract/private/arrow.rkt | 16 ++--- .../racket/contract/private/basic-opters.rkt | 5 +- collects/racket/contract/private/blame.rkt | 66 +++++++++++++++---- collects/racket/contract/private/box.rkt | 6 +- collects/racket/contract/private/ds.rkt | 8 +-- collects/racket/contract/private/hash.rkt | 9 ++- collects/racket/contract/private/misc.rkt | 63 +++++++++--------- collects/racket/contract/private/opt.rkt | 2 +- collects/racket/contract/private/opters.rkt | 24 +++---- .../racket/contract/private/parametric.rkt | 5 +- collects/racket/contract/private/prop.rkt | 3 +- .../racket/contract/private/struct-dc.rkt | 4 +- .../racket/contract/private/struct-prop.rkt | 3 +- collects/racket/contract/private/vector.rkt | 21 +++--- .../scribblings/reference/contracts.scrbl | 39 ++++++++--- collects/tests/racket/contract-test.rktl | 11 +++- 16 files changed, 168 insertions(+), 117 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 6977c109bb..1a0e713ff6 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -113,7 +113,7 @@ v4 todo: [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))]) (λ (val) (unless (procedure? val) - (raise-blame-error orig-blame val "expected a procedure, ~a ~v" (given/produced orig-blame) val)) + (raise-blame-error orig-blame val '(expected: "a procedure," given: "~v") val)) (wrapper val (make-keyword-procedure @@ -389,12 +389,12 @@ v4 todo: (if (and (null? req-kwd) (null? opt-kwd)) (λ (kwds kwd-args . args) (raise-blame-error (blame-swap blame) val - "expected no keywords")) + '(expected: "no keywords"))) (λ (kwds kwd-args . args) (define args-len (length args)) (unless (valid-number-of-args? args) (raise-blame-error (blame-swap blame) val - "received ~a argument~a, expected ~a" + '("received ~a argument~a," expected: "~a") args-len (if (= args-len 1) "" "s") arity-string)) ;; these two for loops are doing O(n^2) work that could be linear @@ -402,7 +402,7 @@ v4 todo: (for ([req-kwd (in-list req-kwd)]) (unless (memq req-kwd kwds) (raise-blame-error (blame-swap blame) val - "expected keyword argument ~a" + '(expected "keyword argument ~a") req-kwd))) (for ([k (in-list kwds)]) (unless (memq k all-kwds) @@ -416,7 +416,7 @@ v4 todo: (unless (valid-number-of-args? args) (define args-len (length args)) (raise-blame-error (blame-swap blame) val - "received ~a argument~a, expected ~a" + '("received ~a argument~a," expected: "~a") args-len (if (= args-len 1) "" "s") arity-string)) (apply basic-lambda args)) (λ args @@ -1873,7 +1873,7 @@ v4 todo: (raise-blame-error blame val - "expected a ~a that accepts ~a~a~a argument~a~a~a, ~a: ~e" + '(expected" a ~a that accepts ~a~a~a argument~a~a~a," given: "~e") (if mtd? "method" "procedure") (if (zero? dom-length) "no" dom-length) (if (null? optionals) "" " mandatory") @@ -1882,7 +1882,6 @@ v4 todo: (if (zero? optionals) "" (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s"))) (keyword-error-text mandatory-kwds optional-keywords) - (given/produced blame) val))] [else passes?])) @@ -1949,14 +1948,13 @@ v4 todo: (raise-blame-error blame val - "expected a ~a that accepts ~a argument~a and arbitrarily more~a, ~a: ~e" + '(expected "a ~a that accepts ~a argument~a and arbitrarily more~a," given: "~e") (if mtd? "method" "procedure") (cond [(zero? dom-length) "no"] [else dom-length]) (if (= 1 dom-length) "" "s") (keyword-error-text mandatory-kwds optional-kwds) - (given/produced blame) val))] [else passes?])) diff --git a/collects/racket/contract/private/basic-opters.rkt b/collects/racket/contract/private/basic-opters.rkt index b2962605f9..4406e5eb4e 100644 --- a/collects/racket/contract/private/basic-opters.rkt +++ b/collects/racket/contract/private/basic-opters.rkt @@ -32,7 +32,7 @@ (raise-blame-error blame val - "expected ~a" + '(expected: "~a") pred-name)) ;; @@ -93,9 +93,8 @@ (raise-blame-error blame val - "expected: ~s, ~a: ~e" + '(expected: "~s," given: "~e") (contract-name ctc) - (given/produced blame) val))) #:lifts (interleave-lifts diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index 6ef8edb9da..d7229fca96 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -15,11 +15,11 @@ blame-add-context blame-add-unknown-context blame-context - given/produced raise-blame-error current-blame-format - (struct-out exn:fail:contract:blame)) + (struct-out exn:fail:contract:blame) + blame-fmt->-string) (define (blame=? a b equal?/recur) (and (equal?/recur (blame-source a) (blame-source b)) @@ -86,13 +86,62 @@ (define-struct (exn:fail:contract:blame exn:fail:contract) [object] #:transparent) -(define (raise-blame-error b x fmt . args) +(define (raise-blame-error blame x fmt . args) (raise (make-exn:fail:contract:blame - ((current-blame-format) b x (apply format fmt args)) + ((current-blame-format) + blame x + (apply format (blame-fmt->-string blame fmt) args)) (current-continuation-marks) - b))) + blame))) +(define (blame-fmt->-string blame fmt) + (cond + [(string? fmt) fmt] + [else + (let loop ([strs fmt] + [so-far '()] + [last-ended-in-whitespace? #t]) + (cond + [(null? strs) + (apply string-append (reverse so-far))] + [else + (define fst (car strs)) + (define nxt + (cond + [(eq? 'given: fst) (if (blame-original? blame) + "produced:" + "given:")] + [(eq? 'given fst) (if (blame-original? blame) + "produced" + "given")] + [(eq? 'expected: fst) (if (blame-original? blame) + "promised:" + "expected:")] + [(eq? 'expected fst) (if (blame-original? blame) + "promised" + "expected")] + [else fst])) + (define new-so-far + (if (or last-ended-in-whitespace? + (regexp-match #rx"^ " nxt)) + (cons nxt so-far) + (list* nxt " " so-far))) + (loop (cdr strs) + new-so-far + (regexp-match #rx" $" nxt))]))])) + + +(define (given/produced blame) + (if (blame-original? blame) + "produced" + "given")) + +(define (expected/promised blame) + (if (blame-original? blame) + "expected" + "promised")) + (define (default-blame-format blme x custom-message) (define source-message (source-location->string (blame-source blme))) (define positive-message (show/display (convert-blame-party (blame-positive blme)))) @@ -113,7 +162,7 @@ (format " at: ~a" source-message))) (define self-or-not (if (blame-original? blme) - "self-contract violation" + "broke it's contract" "contract violation")) (define start-of-message @@ -202,8 +251,3 @@ (define current-blame-format (make-parameter default-blame-format)) - -(define (given/produced blame) - (if (blame-original? blame) - "produced" - "given")) \ No newline at end of file diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt index 1ba5f38e05..4ea01f7c16 100644 --- a/collects/racket/contract/private/box.rkt +++ b/collects/racket/contract/private/box.rkt @@ -18,14 +18,14 @@ (define elem-ctc (base-box/c-content ctc)) (define immutable (base-box/c-immutable ctc)) (unless (box? val) - (raise-blame-error blame val "expected a box, ~a: ~a" (given/produced blame) val)) + (raise-blame-error blame val '(expected "a box," given: "~e") val)) (case immutable [(#t) (unless (immutable? val) - (raise-blame-error blame val "expected an immutable box, ~a: ~a" (given/produced blame) val))] + (raise-blame-error blame val '(expected "an immutable box," given: "~e") val))] [(#f) (when (immutable? val) - (raise-blame-error blame val "expected a mutable box, ~a: ~a" (given/produced blame) val))] + (raise-blame-error blame val '(expected "a mutable box," given: "~e") val))] [(dont-care) (void)])) (define (box/c-first-order ctc) diff --git a/collects/racket/contract/private/ds.rkt b/collects/racket/contract/private/ds.rkt index 9247cabedf..1cee054dcd 100644 --- a/collects/racket/contract/private/ds.rkt +++ b/collects/racket/contract/private/ds.rkt @@ -253,7 +253,7 @@ it around flattened out. (raise-blame-error blame val - "expected: ~s, ~a ~e" 'name (given/produced blame) val)) + '(expected: "~s," given: "~e") 'name val)) (cond [(already-there? contract/info val lazy-depth-to-look) val] @@ -459,9 +459,8 @@ it around flattened out. (raise-blame-error blame val - "expected: ~s, ~a ~e" + '(expected: "~s," given: "~e") (contract-name ctc) - (given/produced blame) val)])) #:lifts lifts #:superlifts superlifts @@ -536,7 +535,8 @@ it around flattened out. (raise-blame-error (contract/info-blame contract/info) stct - "failed `and' clause, ~a ~e" (given/produced (contract/info-blame contract/info)) stct))) + '("failed `and' clause," given: "~e") + stct))) (define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor) (make-struct-type-property 'evaluate-attr-prop)) diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt index a7f4f4a643..95d188a393 100644 --- a/collects/racket/contract/private/hash.rkt +++ b/collects/racket/contract/private/hash.rkt @@ -82,23 +82,22 @@ (define immutable (base-hash/c-immutable ctc)) (define flat? (flat-hash/c? ctc)) (unless (hash? val) - (raise-blame-error blame val "expected a hash, ~a: ~e" (given/produced blame) val)) + (raise-blame-error blame val '(expected "a hash," given: "~e") val)) (when (and (not flat?) (not (flat-contract? dom-ctc)) (not (hash-equal? val))) (raise-blame-error blame val - "expected equal?-based hash table due to higher-order domain contract, ~a: ~e" - (given/produced blame) + '(expected "equal?-based hash table due to higher-order domain contract," given: "~e") val)) (case immutable [(#t) (unless (immutable? val) (raise-blame-error blame val - "expected an immutable hash, ~a: ~e" (given/produced blame) val))] + '(expected "an immutable hash," given: "~e") val))] [(#f) (when (immutable? val) (raise-blame-error blame val - "expected an mutable hash, ~a: ~e" (given/produced blame) val))] + '(expected "a mutable hash," given: "~e") val))] [(dont-care) (void)])) (define (hash/c-first-order ctc) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 2630c53dfb..196f5c4598 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -220,16 +220,14 @@ (if candidate-proc (candidate-proc val) (raise-blame-error blame val - "none of the branches of the or/c matched, ~a: ~e" - (given/produced blame) + '("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, ~a: ~e" + '("two of the clauses in the or/c might both match: ~s and ~s," given: "~e") (contract-name candidate-contract) (contract-name (car contracts)) - (given/produced blame) val) (loop (cdr checks) (cdr procs) @@ -356,19 +354,18 @@ (λ (val) (let loop ([predicates (first-order-and/c-predicates ctc)] [ctcs (base-and/c-ctcs ctc)]) - (cond - [(null? predicates) val] - [else - (if ((car predicates) val) - (loop (cdr predicates) (cdr ctcs)) - (raise-blame-error - blame - val - "expected: ~s, ~a: ~e, which isn't ~s" - (contract-name ctc) - (given/produced blame) - val - (contract-name (car ctcs))))]))))) + (cond + [(null? predicates) val] + [else + (if ((car predicates) val) + (loop (cdr predicates) (cdr ctcs)) + (raise-blame-error + blame + val + '(expected: "~s," given: "~e, which isn't ~s") + (contract-name ctc) + val + (contract-name (car ctcs))))]))))) (define (and-stronger? this that) (and (base-and/c? that) @@ -645,9 +642,8 @@ (λ (val) (unless (predicate? val) (raise-blame-error blame val - "expected: ~s, ~a: ~e" + '(expected: "~s," given "~e") 'type-name - (given/produced blame) val)) (check-all p-app val)))) (cond @@ -692,8 +688,8 @@ [cdr-p (cdr-proj (blame-add-context blame "the cdr of"))]) (λ (v) (unless (pair? v) - (raise-blame-error blame v "expected , ~a: ~e" - (given/produced blame) + (raise-blame-error blame v + '(expected "," given: "~e") v)) (combine v (car-p (car v)) (cdr-p (cdr v)))))) (cond @@ -747,17 +743,18 @@ (lambda (blame) (lambda (x) (unless (list? x) - (raise-blame-error blame x "expected a list, ~a: ~e" (given/produced blame) x)) + (raise-blame-error blame x '(expected "a list," given: "~e") x)) (let* ([args (generic-list/c-args c)] [expected (length args)] [actual (length x)]) (unless (= actual expected) (raise-blame-error blame x - "expected a list of ~a elements, but ~a ~a elements in: ~e" + '(expected "a list of ~a elements, but" given "~a element~a in: ~e") expected - (given/produced blame) - actual x)) + actual + (if (= actual 1) "" "s") + x)) (for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)]) (((contract-projection arg/c) (add-list-context blame i)) @@ -773,15 +770,16 @@ (arg/c (add-list-context blame i)))) (λ (x) (unless (list? x) - (raise-blame-error blame x "expected a list, ~a: ~e" (given/produced blame) x)) + (raise-blame-error blame x '(expected "a list," given: "~e") x)) (define actual (length x)) (unless (= actual expected) (raise-blame-error blame x - "expected a list of ~a elements, but ~a ~a elements in: ~e" + '(expected "a list of ~a elements, but" given "~a element~a in: ~e") expected - (given/produced blame) - actual x)) + actual + (if (= actual 1) "" "s") + x)) (for/list ([item (in-list x)] [proj (in-list projs)]) (proj item))))) @@ -833,8 +831,7 @@ (raise-blame-error blame val - "expected , ~a: ~e" - (given/produced blame) + '(expected "," given: "~e") val)) (delay (p-app (force val)))))) #:first-order promise?)))) @@ -861,7 +858,7 @@ partial-neg-contract partial-pos-contract)] [else - (raise-blame-error blame val "expected a parameter")]))))) + (raise-blame-error blame val '(expected "a parameter"))]))))) #:name (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))) @@ -911,7 +908,7 @@ (raise-blame-error blame val - "~s accepts no values, given: ~e" + '("~s accepts no values," given: "~e") (none/c-name ctc) val)))) diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 097122a724..7894c3ea39 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -97,7 +97,7 @@ #:chaperone #t)) (define (opt-constant-contract-failure blame val compare should-be) - (raise-blame-error blame val "expected a value ~a to ~e" compare should-be)) + (raise-blame-error blame val '(expected "a value ~a to ~e") compare should-be)) (begin-for-syntax (define-struct define-opt/recursive-fn (transformer internal-fn neg-blame?-id) diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt index 0652412995..5ea37a8e59 100644 --- a/collects/racket/contract/private/opters.rkt +++ b/collects/racket/contract/private/opters.rkt @@ -183,10 +183,8 @@ (raise-blame-error blame val - "expected a number between ~a and ~a, ~a: ~e" - lo hi - (given/produced blame) - val)) + '(expected "a number between ~a and ~a," given: "~e") + lo hi val)) (define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg) (with-syntax ([comparison comparison]) @@ -222,10 +220,8 @@ (raise-blame-error blame val - "expected a number ~a ~a, ~a: ~e" - (object-name comparison) m - (given/produced blame) - val)) + '(expected "a number ~a ~a," given: "~e") + (object-name comparison) m val)) (define/opter (=/c opt/i opt/info stx) @@ -308,9 +304,8 @@ (raise-blame-error blame val - "expected: ~s, ~a: ~e" + '(expected: "~s," given: "~e") (contract-name ctc) - (given/produced blame) val)))) #:lifts (append (optres-lifts optres-hd) (optres-lifts optres-tl)) @@ -358,8 +353,8 @@ blame val #,(if non-empty? - "expected a non-empty list" - "expected a list"))))) + #''(expected "a non-empty list") + #''(expected "a list")))))) #:lifts (optres-lifts optres-ele) #:superlifts (optres-superlifts optres-ele) #:partials (optres-partials optres-ele) @@ -589,13 +584,12 @@ (define (raise-flat-arrow-err blame val n) (raise-blame-error blame val - "expected a procedure matching the contract ~s" + '(expected "a procedure matching the contract ~s") `(-> ,@(build-list n (λ (x) 'any/c)) any))) (define (bad-number-of-arguments blame val args dom-len) (define num-values (length args)) (raise-blame-error (blame-swap blame) val - "expected ~a argument~a, ~a ~a argument~a" + '(expected "~a argument~a," given "~a argument~a") dom-len (if (= dom-len 1) "" "s") - (given/produced blame) num-values (if (= num-values 1) "" "s"))) diff --git a/collects/racket/contract/private/parametric.rkt b/collects/racket/contract/private/parametric.rkt index a8d790b1f7..3f7af29e6a 100644 --- a/collects/racket/contract/private/parametric.rkt +++ b/collects/racket/contract/private/parametric.rkt @@ -46,7 +46,7 @@ (lambda (p) (unless (procedure? p) - (raise-blame-error blame p "expected a procedure; ~a: ~e" (given/produced blame) p)) + (raise-blame-error blame p '(expected "a procedure;" given: "~e") p)) (make-keyword-procedure (lambda (keys vals . args) (keyword-apply (wrap p) keys vals args)) (case-lambda @@ -80,7 +80,6 @@ (lambda (x) (if ((barrier-contract-pred c) x) ((barrier-contract-get c) x) - (raise-blame-error blame x "expected a(n) ~a; ~a: ~e" + (raise-blame-error blame x '(expected "a(n) ~a;" given: "~e") (barrier-contract-name c) - (given/produced blame) x)))))))) diff --git a/collects/racket/contract/private/prop.rkt b/collects/racket/contract/private/prop.rkt index b0bbecaada..287203d4a0 100644 --- a/collects/racket/contract/private/prop.rkt +++ b/collects/racket/contract/private/prop.rkt @@ -262,9 +262,8 @@ (if (first-order x) x (raise-blame-error b x - "expected: ~s, ~a: ~e" + '(expected: "~s," given: "~e") name - (given/produced b) x)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index f1c26fd990..8d28bdb22a 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -189,7 +189,7 @@ v] [else (unless (pred? v) - (raise-blame-error blame v "expected a ~a" + (raise-blame-error blame v '(expected: "~a") (base-struct/dc-struct-name ctc))) (let loop ([subcontracts (base-struct/dc-subcontracts ctc)] [projs projs] @@ -955,7 +955,7 @@ (define (struct/dc-error blame obj what) (raise-blame-error blame obj - "expected a struct of type ~a" + '(expected "a struct of type ~a") what)) (define-syntax (struct/c stx) diff --git a/collects/racket/contract/private/struct-prop.rkt b/collects/racket/contract/private/struct-prop.rkt index c9b5fdfe10..952517b5ac 100644 --- a/collects/racket/contract/private/struct-prop.rkt +++ b/collects/racket/contract/private/struct-prop.rkt @@ -14,8 +14,7 @@ (lambda (x) (unless (struct-type-property? x) (raise-blame-error blame x - "expected struct-type-property, ~a: ~e" - (given/produced blame) + '(expected "struct-type-property," given: "~e") x)) (let-values ([(nprop _pred _acc) (make-struct-type-property diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt index 480b031e9e..341dae268e 100644 --- a/collects/racket/contract/private/vector.rkt +++ b/collects/racket/contract/private/vector.rkt @@ -49,20 +49,20 @@ [flat? (flat-vectorof? c)]) (λ (val fail first-order?) (unless (vector? val) - (fail val "expected a vector, got ~a" val)) + (fail val '(expected "a vector," given: "~e") val)) (cond [(eq? immutable #t) (unless (immutable? val) - (fail val "expected an immutable vector, got ~a" val))] + (fail val '(expected "an immutable vector," given: "~e") val))] [(eq? immutable #f) (when (immutable? val) - (fail val "expected an mutable vector, got ~a" val))] + (fail val '(expected "an mutable vector," given: "~e" val)))] [else (void)]) (when first-order? (for ([e (in-vector val)] [n (in-naturals)]) (unless (contract-first-order-passes? elem-ctc e) - (fail val "expected: ~s for element ~v, got ~v" (contract-name elem-ctc) n e)))) + (fail val '(expected: "~s for element ~s," given "~e") (contract-name elem-ctc) n e)))) #t))) (define (vectorof-first-order ctc) @@ -182,29 +182,24 @@ (define elem-ctcs (base-vector/c-elems ctc)) (define immutable (base-vector/c-immutable ctc)) (unless (vector? val) - (raise-blame-error blame val "expected a vector, ~a: ~e" - (given/produced blame) - val)) + (raise-blame-error blame val '(expected "a vector," given: "~e") val)) (cond [(eq? immutable #t) (unless (immutable? val) (raise-blame-error blame val - "expected an immutable vector, ~a: ~e" - (given/produced blame) + '(expected "an immutable vector," given: "~e") val))] [(eq? immutable #f) (when (immutable? val) (raise-blame-error blame val - "expected an mutable vector, ~a: ~e" - (given/produced blame) + '(expected "a mutable vector," given: "~e") val))] [else (void)]) (define elem-count (length elem-ctcs)) (unless (= (vector-length val) elem-count) - (raise-blame-error blame val "expected a vector of ~a element~a, ~a: ~e" + (raise-blame-error blame val '(expected "a vector of ~a element~a," given: "~e") elem-count (if (= elem-count 1) "" "s") - (given/produced blame) val))) (define (vector/c-first-order ctc) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 28836f725c..7503da52c5 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1273,7 +1273,7 @@ use in the contract system: (raise-blame-error blame val - "expected , given: ~e" + '(expected "," given: "~e") val)))) ] The new argument specifies who is to be blamed for @@ -1304,7 +1304,7 @@ Compare that to the projection for our function contract: (raise-blame-error blame val - "expected a procedure of one argument, given: ~e" + '(expected "a procedure of one argument," given: "~e") val))))) ] @@ -1362,7 +1362,7 @@ when a contract violation is detected. (raise-blame-error blame val - "expected a procedure of one argument, given: ~e" + '(expected "a procedure of one argument," given: "~e") val)))))) ] @@ -1380,7 +1380,9 @@ the contract library primitives below. (if (test x) x (raise-blame-error - b x "expected <~a>, given: ~e" name x))))] + b x + '(expected "<~a>," given: "~e") + name x))))] [#:stronger stronger (-> contract? contract? boolean?)]) contract?] @defproc[(make-chaperone-contract @@ -1392,7 +1394,9 @@ the contract library primitives below. (if (test x) x (raise-blame-error - b x "expected <~a>, given: ~e" name x))))] + b x + '(expected "<~a>," given: "~e") + name x))))] [#:stronger stronger (-> contract? contract? boolean?)]) chaperone-contract?] @defproc[(make-flat-contract @@ -1404,7 +1408,9 @@ the contract library primitives below. (if (test x) x (raise-blame-error - b x "expected <~a>, given: ~e" name x))))] + b x + '(expected "<~a>," given: "~e") + name x))))] [#:stronger stronger (-> contract? contract? boolean?)]) flat-contract?] )]{ @@ -1468,7 +1474,7 @@ was passed as the second argument to @racket[contract-stronger?]. (λ (x) (range (f (domain x)))) (raise-blame-error b f - "expected a function of one argument, got: ~e" + '(expected "a function of one argument," 'given: "~e") f))))))) (contract int->int/c "not fun" 'positive 'negative) (define halve @@ -1630,17 +1636,32 @@ the other; both are provided for convenience and clarity. position @racket[b] has. } -@defproc[(raise-blame-error [b blame?] [x any/c] [fmt string?] [v any/c] ...) +@defproc[(raise-blame-error [b blame?] + [x any/c] + [fmt (or/c string? + (listof (or/c string? + 'given 'given: + 'expected 'expected:)))] + [v any/c] ...) none/c]{ Signals a contract violation. The first argument, @racket[b], records the current blame information, including positive and negative parties, the name of the contract, the name of the value, and the source location of the contract application. The second argument, @racket[x], is the value that failed to -satisfy the contract. The remaining arguments are a format string, +satisfy the contract. + +The remaining arguments are a format string, @racket[fmt], and its arguments, @racket[v ...], specifying an error message specific to the precise violation. +If @racket[fmt] is a list, then the elements are concatenated together +(with spaces added, unless there are already spaces at the ends of the strings), +after first replacing symbols with either their string counterparts, or +replacing @racket['given] with @racket["produced"] and +@racket['expected] with @racket["promised"], depending on whether or not +the @racket[b] argument has been swapped or not (see @racket[blame-swap]). + } @defstruct[(exn:fail:contract:blame exn:fail:contract) ([object blame?])]{ diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 6493a6bbf1..7e845fd034 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -13,6 +13,7 @@ (namespace-require 'scheme/contract) (namespace-require 'scheme/set) (namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?)) + (namespace-require '(only racket/contract/private/blame blame-fmt->-string make-blame)) (namespace-require 'scheme/class) (namespace-require 'scheme/promise) (namespace-require 'scheme/match)) @@ -143,7 +144,7 @@ (define (has-proper-blame? msg) (define reg (cond - [(eq? blame 'pos) #rx"self-contract violation[\n:,].*blaming: pos"] + [(eq? blame 'pos) #rx"broke it's contract[\n:,].*blaming: pos"] [(eq? blame 'neg) #rx"blaming: neg"] [(string? blame) (string-append "blaming: " (regexp-quote blame))] [else #f])) @@ -12741,6 +12742,12 @@ so that propagation occurs. 0) 1))) + (let* ([blame-pos (contract-eval '(make-blame #'here #f (λ () 'integer?) 'positive 'negative #t))] + [blame-neg (contract-eval `(blame-swap ,blame-pos))]) + (ctest "something ~a" blame-fmt->-string ,blame-neg "something ~a") + (ctest "promised: ~s; produced: ~e" blame-fmt->-string ,blame-pos '(expected: "~s;" given: "~e")) + (ctest "expected: ~s; given: ~e" blame-fmt->-string ,blame-neg '(expected: "~s;" given: "~e"))) + ; ; ; @@ -13581,7 +13588,7 @@ so that propagation occurs. (eval '(require 'pce1-bug))) (λ (x) (and (exn:fail:contract:blame? x) - (regexp-match #rx"the-defined-variable1: self-contract violation" (exn-message x))))) + (regexp-match #rx"the-defined-variable1: broke it's contract" (exn-message x))))) (contract-error-test 'contract-error-test9