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

another attempt to handle the #:important flag properly for blame objects

Browse Source 
related to PR 13692
This commit is contained in:
Robby Findler 2013-04-15 21:50:53 -05:00
parent 11f74fc571
commit ffd7b8fde3
2 changed files with 47 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -183,11 +183,11 @@
new-so-far new-so-far
(regexp-match #rx" $" nxt))]))])) (regexp-match #rx" $" nxt))]))]))
(define (blame/important-original? blame) (define (blame/important-original? blme)
(define i (blame-important blame)) (define i (blame-important blme))
(cond (cond
[i (important-sense-swapped? i)] [i (equal? (important-sense-swapped? i) (blame-original? blme))]
[else (blame-original? blame)])) [else (blame-original? blme)]))
(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)))
@ -207,21 +207,19 @@
#f #f
(format " at: ~a" source-message))) (format " at: ~a" source-message)))
(define (self-or-not which-way?) (define self-or-not
(if which-way? (if (blame/important-original? blme)
"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" (format "~a: ~a" (important-name (blame-important blme)) self-or-not)]
(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 (blame-original? blme)))] (format "~a: ~a" (blame-value blme) self-or-not)]
[else [else
(format "~a:" (self-or-not (blame-original? blme)))])) (format "~a:" self-or-not)]))
(define blame-parties (blame-positive blme)) (define blame-parties (blame-positive blme))
(define blaming-line (define blaming-line

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

@ -8742,8 +8742,26 @@
'neg)]) 'neg)])
(send (new cls%) m 3 #t))) (send (new cls%) m 3 #t)))
(let ([expected-given?
(λ (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))))]
[promised-produced?
(λ (exn) (and (regexp-match? #rx"callback: broke its contract" (exn-message exn))
(regexp-match? #rx"promised: boolean[?]" (exn-message exn))
(regexp-match? #rx"produced: 1" (exn-message exn))))])
(contract-error-test (contract-error-test
'class/c-tl-message 'blame-important1
'(send (new (contract (class/c [callback (->m boolean? void)])
(class object%
(super-new)
(define/public (callback n) (void)))
'pos
'neg))
callback 1)
expected-given?)
(contract-error-test
'blame-important2
'((contract (-> (class/c (callback (->m boolean? any))) '((contract (-> (class/c (callback (->m boolean? any)))
any) any)
(λ (c%) (send (new c%) callback 1)) (λ (c%) (send (new c%) callback 1))
@ -8751,9 +8769,17 @@
(class object% (class object%
(super-new) (super-new)
(define/public (callback x) 3))) (define/public (callback x) 3)))
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn)) expected-given?)
(regexp-match? #rx"expected: boolean[?]" (exn-message exn)) (contract-error-test
(regexp-match? #rx"given: 1" (exn-message exn))))) 'blame-important3
'((contract (-> (class/c (callback (->m (-> boolean? void?) any)))
any)
(λ (c%) (send (new c%) callback void))
'pos 'neg)
(class object%
(super-new)
(define/public (callback f) (f 1))))
promised-produced?))
; ;