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

adjust contract violation message by putting the name at the start of the message. For example, this:

Browse Source 
contract violation, expected <(or/c (quote clean) (quote armed) (quote tained))>, given: #f
  contract on wrapped from 'zo-structs, blaming 'no-dep
  contract:
     (->
        any/c
	(listof wrap?)
	(or/c 'clean 'armed 'tained)
	wrapped?)
  at: C:\tmp3.rkt:6.21

becomes this:

wrapped: contract violation, expected <(or/c (quote clean) (quote armed) (quote tained))>, given: #f
  contract from 'zo-structs, blaming 'no-dep
  contract:
     (->
        any/c
        (listof wrap?)
        (or/c 'clean 'armed 'tained)
        wrapped?)
  at: C:\tmp3.rkt:6.21

(apologies if the indenting isn't quite right above; vi messed with it when I tried to paste it in ...)
This commit is contained in:
Robby Findler 2011-07-02 23:58:39 +08:00
parent 3157955d40
commit df6590b80f
2 changed files with 20 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -76,19 +76,18 @@
"\n" "\n"
(if (string=? source-message "") (if (string=? source-message "")
"" ""
(format " at: ~a" source-message))))] (format " at: ~a" source-message))))])
[value-message (if (blame-value b)
(format " on ~a" (show/display (blame-value b)))
"")])
;; use (regexp-match #rx"\n" ...) to find out if show/display decided that this ;; use (regexp-match #rx"\n" ...) to find out if show/display decided that this
;; is a multiple-line message and adjust surrounding formatting accordingly ;; is a multiple-line message and adjust surrounding formatting accordingly
(cond (cond
[(blame-original? b) [(blame-original? b)
(define start-of-message
(if (blame-value b)
(format "~a: self-contract violation," (blame-value b))
"self-contract violation:"))
(string-append (string-append
(format "self-contract violation: ~a\n" custom-message) (format "~a ~a\n" start-of-message custom-message)
(format " contract~a from ~a~a blaming ~a~a" (format " contract from ~a~a blaming ~a~a"
value-message
positive-message positive-message
(if (regexp-match #rx"\n" positive-message) (if (regexp-match #rx"\n" positive-message)
" " " "
@ -100,10 +99,13 @@
contract-message+at)] contract-message+at)]
[else [else
(define negative-message (show/display (blame-negative b))) (define negative-message (show/display (blame-negative b)))
(define start-of-message
(if (blame-value b)
(format "~a: contract violation," (blame-value b))
"contract violation:"))
(string-append (string-append
(format "contract violation: ~a\n" custom-message) (format "~a ~a\n" start-of-message custom-message)
(format " contract~a from ~a~a blaming ~a~a" (format " contract from ~a~a blaming ~a~a"
value-message
negative-message negative-message
(if (regexp-match #rx"\n" negative-message) (if (regexp-match #rx"\n" negative-message)
" " " "

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

@ -92,7 +92,7 @@
(define (has-proper-blame? msg) (define (has-proper-blame? msg)
(define reg (define reg
(case blame (case blame
[(pos) #rx"^self-contract violation"] [(pos) #rx"self-contract violation"]
[(neg) #rx"blaming neg"] [(neg) #rx"blaming neg"]
[else (error 'test/spec-failed "unknown blame name ~s" blame)])) [else (error 'test/spec-failed "unknown blame name ~s" blame)]))
(regexp-match? reg msg)) (regexp-match? reg msg))
@ -11345,7 +11345,7 @@ so that propagation occurs.
(eval '(require 'pce1-bug))) (eval '(require 'pce1-bug)))
(λ (x) (λ (x)
(and (exn? x) (and (exn? x)
(regexp-match #rx"on the-defined-variable1" (exn-message x))))) (regexp-match #rx"the-defined-variable1: self-contract violation" (exn-message x)))))
(contract-error-test (contract-error-test
#'(begin #'(begin
@ -11357,7 +11357,7 @@ so that propagation occurs.
(eval '(the-defined-variable2 #f))) (eval '(the-defined-variable2 #f)))
(λ (x) (λ (x)
(and (exn? x) (and (exn? x)
(regexp-match #rx"on the-defined-variable2" (exn-message x))))) (regexp-match #rx"the-defined-variable2: contract violation" (exn-message x)))))
(contract-error-test (contract-error-test
#'(begin #'(begin
@ -11369,7 +11369,7 @@ so that propagation occurs.
(eval '(the-defined-variable3 #f))) (eval '(the-defined-variable3 #f)))
(λ (x) (λ (x)
(and (exn? x) (and (exn? x)
(regexp-match #rx"on the-defined-variable3" (exn-message x))))) (regexp-match #rx"the-defined-variable3" (exn-message x)))))
(contract-error-test (contract-error-test
#'(begin #'(begin
@ -11381,7 +11381,7 @@ so that propagation occurs.
(eval '((if #t the-defined-variable4 the-defined-variable4) #f))) (eval '((if #t the-defined-variable4 the-defined-variable4) #f)))
(λ (x) (λ (x)
(and (exn? x) (and (exn? x)
(regexp-match #rx"on the-defined-variable4" (exn-message x))))) (regexp-match #rx"^the-defined-variable4" (exn-message x)))))
(contract-error-test (contract-error-test
#'(begin #'(begin
@ -11447,7 +11447,7 @@ so that propagation occurs.
(eval '(g 12))) (eval '(g 12)))
(λ (x) (λ (x)
(and (exn? x) (and (exn? x)
(regexp-match #rx"contract on g 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 +11460,7 @@ so that propagation occurs.
(eval '(g 'a))) (eval '(g 'a)))
(λ (x) (λ (x)
(and (exn? x) (and (exn? x)
(regexp-match #rx"contract on g from 'pce10-bug" (exn-message x))))) (regexp-match #rx"^g.*contract from 'pce10-bug" (exn-message x)))))
(contract-eval (contract-eval
`(,test `(,test