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)))
(λ (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)))))))

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

@ -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)

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

@ -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)

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

@ -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)