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
(regexp-match #rx" $" nxt))]))]))
(define (blame/important-original? blame)
(define i (blame-important blame))
(define (blame/important-original? blme)
(define i (blame-important blme))
(cond
[i (important-sense-swapped? i)]
[else (blame-original? blame)]))
[i (equal? (important-sense-swapped? i) (blame-original? blme))]
[else (blame-original? blme)]))
(define (default-blame-format blme x custom-message)
(define source-message (source-location->string (blame-source blme)))
@ -207,21 +207,19 @@
#f
(format " at: ~a" source-message)))
(define (self-or-not which-way?)
(if which-way?
(define self-or-not
(if (blame/important-original? blme)
"broke its contract"
"contract violation"))
(define start-of-message
(cond
[(blame-important blme)
(format "~a: ~a"
(important-name (blame-important blme))
(self-or-not (important-sense-swapped? (blame-important blme))))]
(format "~a: ~a" (important-name (blame-important blme)) self-or-not)]
[(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
(format "~a:" (self-or-not (blame-original? blme)))]))
(format "~a:" self-or-not)]))
(define blame-parties (blame-positive blme))
(define blaming-line

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

@ -8742,18 +8742,44 @@
'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)))))
(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
'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)))
any)
(λ (c%) (send (new c%) callback 1))
'pos 'neg)
(class object%
(super-new)
(define/public (callback x) 3)))
expected-given?)
(contract-error-test
'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?))
;