suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix the sense of the blame aspects of the blame object has a #:important

Browse Source 
closes PR 13692
This commit is contained in:
Robby Findler 2013-04-13 18:30:22 -05:00
parent ab66b485e5
commit 79955e1204
2 changed files with 44 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/racket/contract/private/blame.rkt
View File

@ -68,16 +68,19 @@
make-blame))
;; 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
blame b
[original? (if swap? (not (blame-original? b)) (blame-original? b))]
[original? new-original?]
[positive (if swap? (blame-negative b) (blame-positive 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))]
[top-known? #t]))
(struct important (name sense-swapped?))
(define (blame-add-unknown-context b)
(define old (blame-context b))
(struct-copy
@ -157,17 +160,17 @@
(define nxt
(cond
[(eq? 'given: fst) (add-indent
(if (blame-original? blame)
(if (blame/important-original? blame)
"produced:"
"given:"))]
[(eq? 'given fst) (if (blame-original? blame)
[(eq? 'given fst) (if (blame/important-original? blame)
"produced"
"given")]
[(eq? 'expected: fst) (add-indent
(if (blame-original? blame)
(if (blame/important-original? blame)
"promised:"
"expected:"))]
[(eq? 'expected fst) (if (blame-original? blame)
[(eq? 'expected fst) (if (blame/important-original? blame)
"promised"
"expected")]
[else fst]))
@ -180,6 +183,12 @@
new-so-far
(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 source-message (source-location->string (blame-source blme)))
@ -198,18 +207,21 @@
#f
(format " at: ~a" source-message)))
(define self-or-not (if (blame-original? blme)
"broke its contract"
"contract violation"))
(define (self-or-not which-way?)
(if which-way?
"broke its contract"
"contract violation"))
(define start-of-message
(cond
[(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)
(format "~a: ~a" (blame-value blme) self-or-not)]
(format "~a: ~a" (blame-value blme) (self-or-not (blame-original? blme)))]
[else
(format "~a:" self-or-not)]))
(format "~a:" (self-or-not (blame-original? blme)))]))
(define blame-parties (blame-positive blme))
(define blaming-line

24
collects/tests/racket/contract-test.rktl
View File

@ -57,10 +57,10 @@
(define (contract-syntax-error-test name exp [reg #rx""])
(test #t
name
(contract-eval `(with-handlers ((exn:fail:syntax?
(lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
(eval ',exp)))))
name
(contract-eval `(with-handlers ((exn:fail:syntax?
(lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
(eval ',exp)))))
;; test/spec-passed : symbol sexp -> void
;; tests a passing specification
@ -155,7 +155,7 @@
(define (has-proper-blame? msg)
(define reg
(cond
[(eq? blame 'pos) #rx"broke its contract[\n:,].*blaming: pos"]
[(eq? blame 'pos) #rx"blaming: pos"]
[(eq? blame 'neg) #rx"blaming: neg"]
[(string? blame) (string-append "blaming: " (regexp-quote blame))]
[else #f]))
@ -8742,6 +8742,20 @@
'neg)])
(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)))))
;
;
; ;; ;; ; ;;