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

added contract-violation->string parameter

Browse Source 
svn: r2314
This commit is contained in:
Robby Findler 2006-02-24 15:37:58 +00:00
parent 2a9f556c8d
commit 3172ffd027
3 changed files with 72 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/mzlib/private/contract-arrow.ss
View File

@ -647,11 +647,11 @@
(object-interface (object-interface
val))]) val))])
(void) (void)
(check-method 'method-name val-mtd-names src-info pos-blame neg-blame orig-str) (check-method val 'method-name val-mtd-names src-info pos-blame neg-blame orig-str)
...) ...)
(unless (field-bound? field-name val) (unless (field-bound? field-name val)
(field-error 'field-name src-info pos-blame neg-blame orig-str)) ... (field-error val 'field-name src-info pos-blame neg-blame orig-str)) ...
(let ([vtable (extract-vtable val)] (let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)]) [method-ht (extract-method-ht val)])
@ -1395,7 +1395,7 @@
(syntax (syntax
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
...) ...)
(val (dom-id x) ...)))))] (val (dom-id x) ...)))))]
@ -1406,11 +1406,11 @@
(syntax (syntax
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
...) ...)
(let-values ([(rng-ids ...) (val (dom-id x) ...)]) (let-values ([(rng-ids ...) (val (dom-id x) ...)])
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) (check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
(let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc) (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc)
pos-blame neg-blame src-info orig-str)] ...) pos-blame neg-blame src-info orig-str)] ...)
(values (rng-ids-x rng-ids) ...))))))))] (values (rng-ids-x rng-ids) ...))))))))]
@ -1429,12 +1429,12 @@
(syntax (syntax
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
... ...
[rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)]) [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)])
(let ([res-id (rng-id (val (dom-id x) ...))]) (let ([res-id (rng-id (val (dom-id x) ...))])
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) (check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
res-id)))))] res-id)))))]
[_ [_
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
@ -1501,7 +1501,7 @@
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
... ...
[rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)])
@ -1515,12 +1515,12 @@
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
... ...
[rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)])
(let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) (check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
(let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc) (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc)
pos-blame neg-blame src-info orig-str)] ...) pos-blame neg-blame src-info orig-str)] ...)
(values (rng-ids-x rng-ids) ...))))))))] (values (rng-ids-x rng-ids) ...))))))))]
@ -1544,13 +1544,13 @@
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
... ...
[rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)] [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]
[rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)]) [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)])
(let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) (check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
res-id)))))] res-id)))))]
[(rng res-id post-expr) [(rng res-id post-expr)
(not (identifier? (syntax res-id))) (not (identifier? (syntax res-id)))
@ -1690,17 +1690,19 @@
f))) f)))
(define (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) (define (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
(unless pre-expr (unless pre-expr
(raise-contract-error src-info (raise-contract-error val
src-info
neg-blame neg-blame
pos-blame pos-blame
orig-str orig-str
"pre-condition expression failure"))) "pre-condition expression failure")))
(define (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) (define (check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
(unless post-expr (unless post-expr
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
@ -1710,6 +1712,7 @@
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-arity-includes? val dom-length)) (procedure-arity-includes? val dom-length))
(raise-contract-error (raise-contract-error
val
src-info src-info
pos-blame pos-blame
neg-blame neg-blame
@ -1720,14 +1723,16 @@
(define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) (define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
(unless (procedure? val) (unless (procedure? val)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
"expected a procedure, got ~e" "expected a procedure, got ~e"
val)) val))
(unless (procedure-arity-includes? val arity) (unless (procedure-arity-includes? val arity)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
@ -1739,14 +1744,16 @@
(define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) (define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
(unless (procedure? val) (unless (procedure? val)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
"expected a procedure, got ~e" "expected a procedure, got ~e"
val)) val))
(unless (procedure-accepts-and-more? val arity) (unless (procedure-accepts-and-more? val arity)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
@ -1760,6 +1767,7 @@
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length)) (procedure-accepts-and-more? val dom-length))
(raise-contract-error (raise-contract-error
val
src-info src-info
pos-blame pos-blame
neg-blame neg-blame
@ -1792,24 +1800,27 @@
(define (check-object val src-info pos-blame neg-blame orig-str) (define (check-object val src-info pos-blame neg-blame orig-str)
(unless (object? val) (unless (object? val)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
"expected an object, got ~e" "expected an object, got ~e"
val))) val)))
(define (check-method method-name val-mtd-names src-info pos-blame neg-blame orig-str) (define (check-method val method-name val-mtd-names src-info pos-blame neg-blame orig-str)
(unless (memq method-name val-mtd-names) (unless (memq method-name val-mtd-names)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str
"expected an object with method ~s" "expected an object with method ~s"
method-name))) method-name)))
(define (field-error field-name src-info pos-blame neg-blame orig-str) (define (field-error val field-name src-info pos-blame neg-blame orig-str)
(raise-contract-error src-info (raise-contract-error val
src-info
pos-blame pos-blame
neg-blame neg-blame
orig-str orig-str

23
collects/mzlib/private/contract-util.ss
View File

@ -4,6 +4,7 @@
(lib "list.ss")) (lib "list.ss"))
(provide raise-contract-error (provide raise-contract-error
contract-violation->string
coerce-contract coerce-contract
coerce/select-contract coerce/select-contract
contract? contract?
@ -85,7 +86,7 @@
exn:fail:contract2? exn:fail:contract2?
(lambda (x) (get x 0))))) (lambda (x) (get x 0)))))
(define (raise-contract-error src-info to-blame other-party contract-sexp fmt . args) (define (default-contract-violation->string val src-info to-blame other-party contract-sexp msg)
(let ([blame-src (src-info-as-string src-info)] (let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp [formatted-contract-sexp
(let ([one-line (format "~s" contract-sexp)]) (let ([one-line (format "~s" contract-sexp)])
@ -102,15 +103,25 @@
(if (symbol? datum) (if (symbol? datum)
(format " on ~a" datum) (format " on ~a" datum)
""))]) ""))])
(raise
(make-exn:fail:contract2
(string->immutable-string
(string-append (format "~a~a broke the contract ~ait had with ~a~a; " (string-append (format "~a~a broke the contract ~ait had with ~a~a; "
blame-src blame-src
to-blame to-blame
formatted-contract-sexp formatted-contract-sexp
other-party other-party
specific-blame) specific-blame)
msg)))
(define contract-violation->string (make-parameter default-contract-violation->string))
(define (raise-contract-error val src-info to-blame other-party contract-sexp fmt . args)
(raise
(make-exn:fail:contract2
(string->immutable-string
((contract-violation->string) val
src-info
to-blame
other-party
contract-sexp
(apply format fmt args))) (apply format fmt args)))
(current-continuation-marks) (current-continuation-marks)
(if src-info (if src-info
@ -120,8 +131,7 @@
(syntax-column src-info) (syntax-column src-info)
(syntax-position src-info) (syntax-position src-info)
(syntax-span src-info))) (syntax-span src-info)))
'()))))) '()))))
(define print-contract-liner (define print-contract-liner
(let ([default (pretty-print-print-line)]) (let ([default (pretty-print-print-line)])
@ -226,6 +236,7 @@
(if (predicate val) (if (predicate val)
val val
(raise-contract-error (raise-contract-error
val
src-info src-info
pos pos
neg neg

5
collects/mzlib/private/contract.ss
View File

@ -976,6 +976,7 @@ add struct contracts for immutable structs?
(lambda (val) (lambda (val)
(unless (predicate?-name val) (unless (predicate?-name val)
(raise-contract-error (raise-contract-error
val
src-info src-info
pos pos
neg neg
@ -1083,6 +1084,7 @@ add struct contracts for immutable structs?
(predicate?-name v)) (predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...) (constructor-name (p-apps (selector-names v)) ...)
(raise-contract-error (raise-contract-error
v
src-info src-info
pos pos
neg neg
@ -1116,6 +1118,7 @@ add struct contracts for immutable structs?
(cons (p-app (selector-name v i)) (cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))]))) (loop (cdr p-apps) (+ i 1))))])))
(raise-contract-error (raise-contract-error
v
src-info src-info
pos pos
neg neg
@ -1186,6 +1189,7 @@ add struct contracts for immutable structs?
(lambda (val) (lambda (val)
(unless (promise? val) (unless (promise? val)
(raise-contract-error (raise-contract-error
val
src-info src-info
pos pos
neg neg
@ -1239,6 +1243,7 @@ add struct contracts for immutable structs?
(lambda (val) (lambda (val)
(unless (predicate-id val) (unless (predicate-id val)
(raise-contract-error (raise-contract-error
val
src-info src-info
pos pos
neg neg