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)
This commit is contained in:
Robby Findler 2012-05-15 17:49:47 -05:00
parent dfa0305bb3
commit 3fceae2715
16 changed files with 168 additions and 117 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 <cons?>, ~a: ~e"
(given/produced blame)
(raise-blame-error blame v
'(expected "<pair?>," 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 <promise>, ~a: ~e"
(given/produced blame)
'(expected "<promise>," 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))))

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1273,7 +1273,7 @@ use in the contract system:
(raise-blame-error
blame
val
"expected <integer>, given: ~e"
'(expected "<integer>," 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?])]{

View File

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