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
parent
dfa0305bb3
commit
3fceae2715
|
|
@ -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?]))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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?])]{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user