fix the sense of the blame aspects of the blame object has a #:important
closes PR 13692
This commit is contained in:
parent
ab66b485e5
commit
79955e1204
|
@ -68,16 +68,19 @@
|
||||||
make-blame))
|
make-blame))
|
||||||
|
|
||||||
;; s : (or/c string? #f)
|
;; s : (or/c string? #f)
|
||||||
(define (blame-add-context b s #:important [important #f] #:swap? [swap? #f])
|
(define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
|
||||||
|
(define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
|
||||||
(struct-copy
|
(struct-copy
|
||||||
blame b
|
blame b
|
||||||
[original? (if swap? (not (blame-original? b)) (blame-original? b))]
|
[original? new-original?]
|
||||||
[positive (if swap? (blame-negative b) (blame-positive b))]
|
[positive (if swap? (blame-negative b) (blame-positive b))]
|
||||||
[negative (if swap? (blame-positive b) (blame-negative b))]
|
[negative (if swap? (blame-positive b) (blame-negative b))]
|
||||||
[important (or important (blame-important b))]
|
[important (if name (important name new-original?) (blame-important b))]
|
||||||
[context (if s (cons s (blame-context b)) (blame-context b))]
|
[context (if s (cons s (blame-context b)) (blame-context b))]
|
||||||
[top-known? #t]))
|
[top-known? #t]))
|
||||||
|
|
||||||
|
(struct important (name sense-swapped?))
|
||||||
|
|
||||||
(define (blame-add-unknown-context b)
|
(define (blame-add-unknown-context b)
|
||||||
(define old (blame-context b))
|
(define old (blame-context b))
|
||||||
(struct-copy
|
(struct-copy
|
||||||
|
@ -157,17 +160,17 @@
|
||||||
(define nxt
|
(define nxt
|
||||||
(cond
|
(cond
|
||||||
[(eq? 'given: fst) (add-indent
|
[(eq? 'given: fst) (add-indent
|
||||||
(if (blame-original? blame)
|
(if (blame/important-original? blame)
|
||||||
"produced:"
|
"produced:"
|
||||||
"given:"))]
|
"given:"))]
|
||||||
[(eq? 'given fst) (if (blame-original? blame)
|
[(eq? 'given fst) (if (blame/important-original? blame)
|
||||||
"produced"
|
"produced"
|
||||||
"given")]
|
"given")]
|
||||||
[(eq? 'expected: fst) (add-indent
|
[(eq? 'expected: fst) (add-indent
|
||||||
(if (blame-original? blame)
|
(if (blame/important-original? blame)
|
||||||
"promised:"
|
"promised:"
|
||||||
"expected:"))]
|
"expected:"))]
|
||||||
[(eq? 'expected fst) (if (blame-original? blame)
|
[(eq? 'expected fst) (if (blame/important-original? blame)
|
||||||
"promised"
|
"promised"
|
||||||
"expected")]
|
"expected")]
|
||||||
[else fst]))
|
[else fst]))
|
||||||
|
@ -180,6 +183,12 @@
|
||||||
new-so-far
|
new-so-far
|
||||||
(regexp-match #rx" $" nxt))]))]))
|
(regexp-match #rx" $" nxt))]))]))
|
||||||
|
|
||||||
|
(define (blame/important-original? blame)
|
||||||
|
(define i (blame-important blame))
|
||||||
|
(cond
|
||||||
|
[i (important-sense-swapped? i)]
|
||||||
|
[else (blame-original? blame)]))
|
||||||
|
|
||||||
(define (default-blame-format blme x custom-message)
|
(define (default-blame-format blme x custom-message)
|
||||||
(define source-message (source-location->string (blame-source blme)))
|
(define source-message (source-location->string (blame-source blme)))
|
||||||
|
|
||||||
|
@ -198,18 +207,21 @@
|
||||||
#f
|
#f
|
||||||
(format " at: ~a" source-message)))
|
(format " at: ~a" source-message)))
|
||||||
|
|
||||||
(define self-or-not (if (blame-original? blme)
|
(define (self-or-not which-way?)
|
||||||
|
(if which-way?
|
||||||
"broke its contract"
|
"broke its contract"
|
||||||
"contract violation"))
|
"contract violation"))
|
||||||
|
|
||||||
(define start-of-message
|
(define start-of-message
|
||||||
(cond
|
(cond
|
||||||
[(blame-important blme)
|
[(blame-important blme)
|
||||||
(format "~a: ~a" (blame-important blme) self-or-not)]
|
(format "~a: ~a"
|
||||||
|
(important-name (blame-important blme))
|
||||||
|
(self-or-not (important-sense-swapped? (blame-important blme))))]
|
||||||
[(blame-value blme)
|
[(blame-value blme)
|
||||||
(format "~a: ~a" (blame-value blme) self-or-not)]
|
(format "~a: ~a" (blame-value blme) (self-or-not (blame-original? blme)))]
|
||||||
[else
|
[else
|
||||||
(format "~a:" self-or-not)]))
|
(format "~a:" (self-or-not (blame-original? blme)))]))
|
||||||
|
|
||||||
(define blame-parties (blame-positive blme))
|
(define blame-parties (blame-positive blme))
|
||||||
(define blaming-line
|
(define blaming-line
|
||||||
|
|
|
@ -155,7 +155,7 @@
|
||||||
(define (has-proper-blame? msg)
|
(define (has-proper-blame? msg)
|
||||||
(define reg
|
(define reg
|
||||||
(cond
|
(cond
|
||||||
[(eq? blame 'pos) #rx"broke its contract[\n:,].*blaming: pos"]
|
[(eq? blame 'pos) #rx"blaming: pos"]
|
||||||
[(eq? blame 'neg) #rx"blaming: neg"]
|
[(eq? blame 'neg) #rx"blaming: neg"]
|
||||||
[(string? blame) (string-append "blaming: " (regexp-quote blame))]
|
[(string? blame) (string-append "blaming: " (regexp-quote blame))]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
@ -8742,6 +8742,20 @@
|
||||||
'neg)])
|
'neg)])
|
||||||
(send (new cls%) m 3 #t)))
|
(send (new cls%) m 3 #t)))
|
||||||
|
|
||||||
|
(contract-error-test
|
||||||
|
'class/c-tl-message
|
||||||
|
'((contract (-> (class/c (callback (->m boolean? any)))
|
||||||
|
any)
|
||||||
|
(λ (c%) (send (new c%) callback 1))
|
||||||
|
'pos 'neg)
|
||||||
|
(class object%
|
||||||
|
(super-new)
|
||||||
|
(define/public (callback x) 3)))
|
||||||
|
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
|
||||||
|
(regexp-match? #rx"expected: boolean[?]" (exn-message exn))
|
||||||
|
(regexp-match? #rx"given: 1" (exn-message exn)))))
|
||||||
|
|
||||||
|
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
; ;; ;; ; ;;
|
; ;; ;; ; ;;
|
||||||
|
|
Loading…
Reference in New Issue
Block a user