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

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

@ -2934,6 +2934,14 @@
(and (exn? x) (and (exn? x)
(regexp-match (regexp-quote "|x y|: 123456789") (exn-message 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 (test/neg-blame
'->i-protect-shared-state '->i-protect-shared-state
'(let ([x 1]) '(let ([x 1])
@ -11447,7 +11455,7 @@ so that propagation occurs.
(eval '(g 12))) (eval '(g 12)))
(λ (x) (λ (x)
(and (exn? 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 (contract-error-test
#'(begin #'(begin
@ -11460,7 +11468,7 @@ so that propagation occurs.
(eval '(g 'a))) (eval '(g 'a)))
(λ (x) (λ (x)
(and (exn? 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 (contract-eval
`(,test `(,test