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)) 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?)
"broke its contract" (if which-way?
"contract violation")) "broke its contract"
"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

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

@ -57,10 +57,10 @@
(define (contract-syntax-error-test name exp [reg #rx""]) (define (contract-syntax-error-test name exp [reg #rx""])
(test #t (test #t
name name
(contract-eval `(with-handlers ((exn:fail:syntax? (contract-eval `(with-handlers ((exn:fail:syntax?
(lambda (x) (and (regexp-match ,reg (exn-message x)) #t)))) (lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
(eval ',exp))))) (eval ',exp)))))
;; test/spec-passed : symbol sexp -> void ;; test/spec-passed : symbol sexp -> void
;; tests a passing specification ;; tests a passing specification
@ -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)))))
; ;
; ;
; ;; ;; ; ;; ; ;; ;; ; ;;