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

new attempt at contract violation error messages

Browse Source
This commit is contained in:
Robby Findler 2010-12-22 10:29:15 -06:00
parent e2e27522fb
commit bb9bd1b07a
4 changed files with 53 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -63,39 +63,46 @@
b)))
(define (default-blame-format b x custom-message)
(let* ([source-message (source-location->prefix (blame-source b))]
(let* ([source-message (regexp-replace #rx": *$" (source-location->prefix (blame-source b)) "")]
[positive-message (show/display (blame-positive b))]
[negative-message (show/display (blame-negative b))]
[contract-message (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)
(string-append contract-message
(if (string=? source-message "")
""
(format " at: ~a" source-message)))
(string-append contract-message
"\n"
(if (string=? source-message "")
""
(format " at: ~a" source-message))))]
[value-message (if (blame-value b)
(format " on ~a" (show/display (blame-value b)))
"")]
[user-message (if (or (blame-original? b)
(equal? (blame-positive b) (blame-user b)))
""
(format " given to ~a" (show/display (blame-user b))))])
"")])
(cond
[(blame-original? b)
(format "~afound a contradiction between the contract ~a~a for ~a and its implementation~a; ~a; to fix adjust either the contract or the implementation of ~a"
source-message
contract-message
value-message
positive-message
user-message
custom-message
positive-message)]
(string-append
(format "self-contract violation: ~a\n" custom-message)
(format " contract~a from ~a\n" value-message positive-message)
contract-message+at)]
[else
(format "~afound a contradiction between the contract ~a~a for ~a and its client ~a~a; ~a; to fix adjust either the contract on ~a or the implementation of ~a"
source-message
contract-message
value-message
negative-message
positive-message
user-message
custom-message
negative-message
positive-message)])))
(define negative-message (show/display (blame-negative b)))
(define user-message
(if (equal? (blame-positive b) (blame-user b))
""
(format " via ~a" (show/display (blame-user b)))))
(string-append
(format "contract violation: ~a\n" custom-message)
(format " contract~a from ~a~a, blaming ~a\n" value-message negative-message user-message positive-message)
contract-message+at)])))
(define (add-newline str)
(if (regexp-match #rx"\n$" str)
str
(string-append str "\n")))
(define ((show f) v)
(let* ([line
@ -123,7 +130,7 @@
(define (show-line-break line port len cols)
(newline port)
(if line
(begin (display " " port) 2)
(begin (display " " port) 4)
0))
(define current-blame-format

9
collects/tests/racket/contract-mzlib-test.rktl
View File

@ -78,9 +78,12 @@ of the contract library does not change over time.
(define (test/spec-failed name expression blame)
(let ()
(define (has-proper-blame? msg)
(regexp-match?
(string-append "the implementation of " (regexp-quote blame))
msg))
(define reg
(case blame
[(pos) #rx"^self-contract violation"]
[(neg) #rx"blaming neg"]
[else (error 'test/spec-failed "unknown blame name ~s" blame)]))
(regexp-match? reg msg))
(printf "testing: ~s\n" name)
(contract-eval
`(,thunk-error-test

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

@ -89,7 +89,11 @@
(define (test/spec-failed name expression blame)
(let ()
(define (has-proper-blame? msg)
(define reg (string-append "the implementation of " (regexp-quote blame)))
(define reg
(case blame
[(pos) #rx"^self-contract violation"]
[(neg) #rx"blaming neg"]
[else (error 'test/spec-failed "unknown blame name ~s" blame)]))
(regexp-match? reg msg))
(printf "testing: ~s\n" name)
(contract-eval
@ -10912,11 +10916,11 @@ so that propagation occurs.
(require 'provide/contract-35/m)
(f #f)))))
(test (format "contract-test.rktl:~a.30: "
(test (format "contract-test.rktl:~a.30"
(+ here-line 8))
'provide/contract-compiled-source-locs
(with-handlers ((exn:fail? (λ (x)
(let ([m (regexp-match #rx"contract-test.rktl[^ ]* " (exn-message x))])
(let ([m (regexp-match #rx"contract-test.rktl[^ ]*.30" (exn-message x))])
(and m (car m))))))
(contract-eval '(require 'provide/contract-35/n)))))
@ -11018,7 +11022,6 @@ so that propagation occurs.
(provide/contract [f (-> integer? integer? integer?)])))
(eval '(require 'pce8-bug1)))
(λ (x)
(printf ">> ~s\n" (exn-message x))
(and (exn? x)
(regexp-match #rx"pce8-bug" (exn-message x)))))
@ -11033,7 +11036,7 @@ so that propagation occurs.
(eval '(g 12)))
(λ (x)
(and (exn? x)
(regexp-match #rx"broke the contract.*on g" (exn-message x)))))
(regexp-match #rx"contract on g from 'pce9-bug" (exn-message x)))))
(contract-error-test
#'(begin
@ -11046,7 +11049,7 @@ so that propagation occurs.
(eval '(g 'a)))
(λ (x)
(and (exn? x)
(regexp-match #rx"broke the contract.*on g" (exn-message x)))))
(regexp-match #rx"contract on g from 'pce10-bug" (exn-message x)))))
(contract-eval
`(,test

8
collects/tests/units/test-unit-contracts.rktl
View File

@ -6,15 +6,15 @@
(define top-level "top-level")
(define (match-blame re msg)
(or (regexp-match? (string-append "(^| )for " re " and its implementation;") msg)
(regexp-match? (string-append "(^| )and its client " re ";") msg)))
(or (regexp-match? (format "blaming ~a" re) msg)
(regexp-match? (format "self-contract violation:.*from ~a" re) msg)))
(define (match-obj re msg)
(regexp-match? (string-append "(^| )on " re " for") msg))
(regexp-match? (string-append "contract on " re " from") msg))
(define (get-ctc-err msg)
(cond
[(regexp-match #rx";[ ]*(.*)" msg)
[(regexp-match #rx"contract violation: ([^\n]*)\n" msg)
=>
(λ (x) (cadr x))]
[else (error 'test-contract-error