parent
5904cea99a
commit
f2a29515d1
|
@ -16,7 +16,7 @@
|
|||
(eval '(require 'contract-test-suite1)))
|
||||
(λ (x)
|
||||
(and (exn:fail:contract:blame? x)
|
||||
(regexp-match #rx"contract from: contract-test-suite1" (exn-message x)))))
|
||||
(regexp-match #rx"at: contract-test-suite1" (exn-message x)))))
|
||||
|
||||
(contract-error-test
|
||||
'assertion2
|
||||
|
@ -27,7 +27,7 @@
|
|||
(eval '(require 'contract-test-suite2)))
|
||||
(λ (x)
|
||||
(and (exn:fail:contract:blame? x)
|
||||
(regexp-match #rx"blaming: contract-test-suite2" (exn-message x)))))
|
||||
(regexp-match #rx"^[^\n]*assertion violation\n" (exn-message x)))))
|
||||
|
||||
(contract-error-test
|
||||
'assertion3
|
||||
|
@ -38,4 +38,4 @@
|
|||
(eval '(require 'contract-test-suite3)))
|
||||
(λ (x)
|
||||
(and (exn:fail:contract:blame? x)
|
||||
(regexp-match #rx"blaming: contract-test-suite3" (exn-message x))))))
|
||||
(not (regexp-match #rx"blaming" (exn-message x)))))))
|
||||
|
|
|
@ -263,9 +263,13 @@
|
|||
(test/spec-passed/result
|
||||
'contract-marks29
|
||||
'(let ()
|
||||
(eval '(define f (invariant-assertion (-> (λ _ (named-blame? 'top-level))
|
||||
(λ _ (named-blame? 'top-level)))
|
||||
(λ (x) 3))))
|
||||
(eval '(define f
|
||||
(let ([nb
|
||||
(λ _ (named-blame?
|
||||
(dynamic-require 'racket/contract/private/blame
|
||||
'invariant-assertion-party)))])
|
||||
(invariant-assertion (-> nb nb)
|
||||
(λ (x) 3)))))
|
||||
(eval '(f 2)))
|
||||
3)
|
||||
|
||||
|
|
|
@ -85,11 +85,10 @@
|
|||
(syntax-case stx ()
|
||||
[(_ ctc e)
|
||||
(quasisyntax/loc stx
|
||||
(let ([me (quote-module-name)])
|
||||
(contract ctc e
|
||||
me me
|
||||
'#,(syntax-local-infer-name stx)
|
||||
'#,(build-source-location-vector #'ctc))))]))
|
||||
(contract ctc e
|
||||
invariant-assertion-party invariant-assertion-party
|
||||
'#,(syntax-local-infer-name stx)
|
||||
'#,(build-source-location-vector #'ctc)))]))
|
||||
|
||||
(define-syntax (-recursive-contract stx)
|
||||
(define (parse-type/kwds arg type kwds)
|
||||
|
|
|
@ -24,7 +24,11 @@
|
|||
raise-blame-error
|
||||
current-blame-format
|
||||
(struct-out exn:fail:contract:blame)
|
||||
blame-fmt->-string)
|
||||
blame-fmt->-string
|
||||
|
||||
invariant-assertion-party)
|
||||
|
||||
(define invariant-assertion-party (string->uninterned-symbol "invariant-assertion"))
|
||||
|
||||
(define (blame=? a b equal?/recur)
|
||||
(and (equal?/recur (blame-source a) (blame-source b))
|
||||
|
@ -289,11 +293,17 @@
|
|||
(define at-line (if (string=? source-message "")
|
||||
#f
|
||||
(format " at: ~a" source-message)))
|
||||
|
||||
(define blame-parties (blame-positive blme))
|
||||
(define invariant-assertion-failure? (equal? blame-parties (list invariant-assertion-party)))
|
||||
|
||||
(define self-or-not
|
||||
(if (blame/important-original? blme)
|
||||
"broke its own contract"
|
||||
"contract violation"))
|
||||
(cond
|
||||
[invariant-assertion-failure?
|
||||
"assertion violation"]
|
||||
[(blame/important-original? blme)
|
||||
"broke its own contract"]
|
||||
[else "contract violation"]))
|
||||
|
||||
(define start-of-message
|
||||
(cond
|
||||
|
@ -304,9 +314,11 @@
|
|||
[else
|
||||
(format "~a" self-or-not)]))
|
||||
|
||||
(define blame-parties (blame-positive blme))
|
||||
(define blaming-line
|
||||
(cond
|
||||
[invariant-assertion-failure?
|
||||
;; cause the blaming-line to be skipped
|
||||
'()]
|
||||
[(null? (cdr blame-parties))
|
||||
(format " blaming: ~a" (convert-blame-singleton (car blame-parties)))]
|
||||
[else
|
||||
|
@ -315,6 +327,12 @@
|
|||
" blaming multiple parties:"
|
||||
(for/list ([party (in-list blame-parties)])
|
||||
(format "\n ~a" (convert-blame-singleton party))))]))
|
||||
|
||||
(define assumption-line
|
||||
(cond
|
||||
[invariant-assertion-failure?
|
||||
'()]
|
||||
[else " (assuming the contract is correct)"]))
|
||||
|
||||
(define on-line
|
||||
(and (blame-important blme)
|
||||
|
@ -355,7 +373,7 @@
|
|||
from-line
|
||||
on-line
|
||||
blaming-line
|
||||
" (assuming the contract is correct)"
|
||||
assumption-line
|
||||
at-line))
|
||||
|
||||
(define (blame-add-extra-field b name field)
|
||||
|
|
Loading…
Reference in New Issue
Block a user