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

adjust invariant-assertion error message to avoid blame

Browse Source 
closes #1681
This commit is contained in:
Robby Findler 2017-05-13 11:01:51 -05:00
parent 5904cea99a
commit f2a29515d1
4 changed files with 38 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-test/tests/racket/contract/assertion.rkt
View File

@ -16,7 +16,7 @@
(eval '(require 'contract-test-suite1))) (eval '(require 'contract-test-suite1)))
(λ (x) (λ (x)
(and (exn:fail:contract:blame? 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 (contract-error-test
'assertion2 'assertion2
@ -27,7 +27,7 @@
(eval '(require 'contract-test-suite2))) (eval '(require 'contract-test-suite2)))
(λ (x) (λ (x)
(and (exn:fail:contract:blame? 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 (contract-error-test
'assertion3 'assertion3
@ -38,4 +38,4 @@
(eval '(require 'contract-test-suite3))) (eval '(require 'contract-test-suite3)))
(λ (x) (λ (x)
(and (exn:fail:contract:blame? 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)))))))

10
pkgs/racket-test/tests/racket/contract/prof.rkt
View File

@ -263,9 +263,13 @@
(test/spec-passed/result (test/spec-passed/result
'contract-marks29 'contract-marks29
'(let () '(let ()
(eval '(define f (invariant-assertion (-> (λ _ (named-blame? 'top-level)) (eval '(define f
(λ _ (named-blame? 'top-level))) (let ([nb
(λ (x) 3)))) (λ _ (named-blame?
(dynamic-require 'racket/contract/private/blame
'invariant-assertion-party)))])
(invariant-assertion (-> nb nb)
(λ (x) 3)))))
(eval '(f 2))) (eval '(f 2)))
3) 3)

9
racket/collects/racket/contract/private/base.rkt
View File

@ -85,11 +85,10 @@
(syntax-case stx () (syntax-case stx ()
[(_ ctc e) [(_ ctc e)
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([me (quote-module-name)]) (contract ctc e
(contract ctc e invariant-assertion-party invariant-assertion-party
me me '#,(syntax-local-infer-name stx)
'#,(syntax-local-infer-name stx) '#,(build-source-location-vector #'ctc)))]))
'#,(build-source-location-vector #'ctc))))]))
(define-syntax (-recursive-contract stx) (define-syntax (-recursive-contract stx)
(define (parse-type/kwds arg type kwds) (define (parse-type/kwds arg type kwds)

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

@ -24,7 +24,11 @@
raise-blame-error raise-blame-error
current-blame-format current-blame-format
(struct-out exn:fail:contract:blame) (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) (define (blame=? a b equal?/recur)
(and (equal?/recur (blame-source a) (blame-source b)) (and (equal?/recur (blame-source a) (blame-source b))
@ -289,11 +293,17 @@
(define at-line (if (string=? source-message "") (define at-line (if (string=? source-message "")
#f #f
(format " at: ~a" source-message))) (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 (define self-or-not
(if (blame/important-original? blme) (cond
"broke its own contract" [invariant-assertion-failure?
"contract violation")) "assertion violation"]
[(blame/important-original? blme)
"broke its own contract"]
[else "contract violation"]))
(define start-of-message (define start-of-message
(cond (cond
@ -304,9 +314,11 @@
[else [else
(format "~a" self-or-not)])) (format "~a" self-or-not)]))
(define blame-parties (blame-positive blme))
(define blaming-line (define blaming-line
(cond (cond
[invariant-assertion-failure?
;; cause the blaming-line to be skipped
'()]
[(null? (cdr blame-parties)) [(null? (cdr blame-parties))
(format " blaming: ~a" (convert-blame-singleton (car blame-parties)))] (format " blaming: ~a" (convert-blame-singleton (car blame-parties)))]
[else [else
@ -315,6 +327,12 @@
" blaming multiple parties:" " blaming multiple parties:"
(for/list ([party (in-list blame-parties)]) (for/list ([party (in-list blame-parties)])
(format "\n ~a" (convert-blame-singleton party))))])) (format "\n ~a" (convert-blame-singleton party))))]))
(define assumption-line
(cond
[invariant-assertion-failure?
'()]
[else " (assuming the contract is correct)"]))
(define on-line (define on-line
(and (blame-important blme) (and (blame-important blme)
@ -355,7 +373,7 @@
from-line from-line
on-line on-line
blaming-line blaming-line
" (assuming the contract is correct)" assumption-line
at-line)) at-line))
(define (blame-add-extra-field b name field) (define (blame-add-extra-field b name field)