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

Changed default blame formatter to report blame parties relative to collection

Browse Source 
and planet directories where appropriate.  Added a test for this behavior.
(cherry picked from commit b3136095ea)
This commit is contained in:
Carl Eastlund 2011-07-08 22:44:57 -04:00 committed by Eli Barzilay
parent 0911365403
commit 18e9e79aa0
2 changed files with 19 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,6 @@
#lang racket/base
(require syntax/srcloc racket/pretty)
(require syntax/srcloc racket/pretty setup/path-to-relative)
(provide blame?
make-blame
@ -63,8 +63,8 @@
b)))
(define (default-blame-format b x custom-message)
(let* ([source-message (regexp-replace #rx": *$" (source-location->prefix (blame-source b)) "")]
[positive-message (show/display (blame-positive b))]
(let* ([source-message (source-location->string (blame-source b))]
[positive-message (show/display (convert-blame-party (blame-positive b)))]
[contract-message (format " contract: ~a" (show/write (blame-contract b)))]
[contract-message+at (if (regexp-match #rx"\n$" contract-message)
@ -98,7 +98,7 @@
"\n"))
contract-message+at)]
[else
(define negative-message (show/display (blame-negative b)))
(define negative-message (show/display (convert-blame-party (blame-negative b))))
(define start-of-message
(if (blame-value b)
(format "~a: contract violation," (blame-value b))
@ -141,6 +141,11 @@
(pretty-write v port)
(get-output-string port)))
(define (convert-blame-party x)
(cond
[(path? x) (path->relative-string/library x)]
[else x]))
(define show/display (show pretty-format/display))
(define show/write (show pretty-format/write))

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

@ -2933,6 +2933,14 @@
(λ (x)
(and (exn? x)
(regexp-match (regexp-quote "|x y|: 123456789") (exn-message x)))))
;; test to make sure the collects directories are appropriately prefixed
(contract-error-test
#'(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol #'here)
(lambda (x)
(and (exn? x)
(regexp-match? #px"<collects>"
(exn-message x)))))
(test/neg-blame
'->i-protect-shared-state
@ -11447,7 +11455,7 @@ so that propagation occurs.
(eval '(g 12)))
(λ (x)
(and (exn? x)
(regexp-match #rx"^g.*contract from 'pce9-bug" (exn-message x)))))
(regexp-match #rx"^g.*contract from pce9-bug" (exn-message x)))))
(contract-error-test
#'(begin
@ -11460,7 +11468,7 @@ so that propagation occurs.
(eval '(g 'a)))
(λ (x)
(and (exn? x)
(regexp-match #rx"^g.*contract from 'pce10-bug" (exn-message x)))))
(regexp-match #rx"^g.*contract from pce10-bug" (exn-message x)))))
(contract-eval
`(,test