From 3172ffd0270d7172d09bbbec9ece2c0324401c17 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 24 Feb 2006 15:37:58 +0000 Subject: [PATCH] added contract-violation->string parameter svn: r2314 --- collects/mzlib/private/contract-arrow.ss | 61 ++++++++++++++---------- collects/mzlib/private/contract-util.ss | 51 ++++++++++++-------- collects/mzlib/private/contract.ss | 5 ++ 3 files changed, 72 insertions(+), 45 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index bea8338f31..6a1bb34463 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -647,11 +647,11 @@ (object-interface val))]) (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) - (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)] [method-ht (extract-method-ht val)]) @@ -1395,7 +1395,7 @@ (syntax ((x ...) (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)] ...) (val (dom-id x) ...)))))] @@ -1406,11 +1406,11 @@ (syntax ((x ...) (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-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) pos-blame neg-blame src-info orig-str)] ...) (values (rng-ids-x rng-ids) ...))))))))] @@ -1429,12 +1429,12 @@ (syntax ((x ...) (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)] ... [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) ...))]) - (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)))))] [_ (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] @@ -1501,7 +1501,7 @@ (syntax ((x ... . rest-x) (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)] ... [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) @@ -1515,12 +1515,12 @@ (syntax ((x ... . rest-x) (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)] ... [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))]) - (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) pos-blame neg-blame src-info orig-str)] ...) (values (rng-ids-x rng-ids) ...))))))))] @@ -1544,13 +1544,13 @@ (syntax ((x ... . rest-x) (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)] ... [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)]) (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)))))] [(rng res-id post-expr) (not (identifier? (syntax res-id))) @@ -1690,17 +1690,19 @@ 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 - (raise-contract-error src-info + (raise-contract-error val + src-info neg-blame pos-blame orig-str "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 - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str @@ -1710,6 +1712,7 @@ (unless (and (procedure? val) (procedure-arity-includes? val dom-length)) (raise-contract-error + val src-info pos-blame neg-blame @@ -1720,14 +1723,16 @@ (define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) (unless (procedure? val) - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str "expected a procedure, got ~e" val)) (unless (procedure-arity-includes? val arity) - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str @@ -1739,14 +1744,16 @@ (define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) (unless (procedure? val) - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str "expected a procedure, got ~e" val)) (unless (procedure-accepts-and-more? val arity) - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str @@ -1760,6 +1767,7 @@ (unless (and (procedure? val) (procedure-accepts-and-more? val dom-length)) (raise-contract-error + val src-info pos-blame neg-blame @@ -1792,24 +1800,27 @@ (define (check-object val src-info pos-blame neg-blame orig-str) (unless (object? val) - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str "expected an object, got ~e" 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) - (raise-contract-error src-info + (raise-contract-error val + src-info pos-blame neg-blame orig-str "expected an object with method ~s" method-name))) - (define (field-error field-name src-info pos-blame neg-blame orig-str) - (raise-contract-error src-info + (define (field-error val field-name src-info pos-blame neg-blame orig-str) + (raise-contract-error val + src-info pos-blame neg-blame orig-str diff --git a/collects/mzlib/private/contract-util.ss b/collects/mzlib/private/contract-util.ss index 59d4d5b600..1ad919f1f9 100644 --- a/collects/mzlib/private/contract-util.ss +++ b/collects/mzlib/private/contract-util.ss @@ -4,6 +4,7 @@ (lib "list.ss")) (provide raise-contract-error + contract-violation->string coerce-contract coerce/select-contract contract? @@ -85,7 +86,7 @@ exn:fail:contract2? (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)] [formatted-contract-sexp (let ([one-line (format "~s" contract-sexp)]) @@ -102,26 +103,35 @@ (if (symbol? 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; " - blame-src - to-blame - formatted-contract-sexp - other-party - specific-blame) - (apply format fmt args))) - (current-continuation-marks) - (if src-info - (list (make-srcloc - (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info))) - '()))))) + (string-append (format "~a~a broke the contract ~ait had with ~a~a; " + blame-src + to-blame + formatted-contract-sexp + other-party + 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))) + (current-continuation-marks) + (if src-info + (list (make-srcloc + (syntax-source src-info) + (syntax-line src-info) + (syntax-column src-info) + (syntax-position src-info) + (syntax-span src-info))) + '())))) (define print-contract-liner (let ([default (pretty-print-print-line)]) @@ -226,6 +236,7 @@ (if (predicate val) val (raise-contract-error + val src-info pos neg diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index d229eb48ba..1c492c65d2 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -976,6 +976,7 @@ add struct contracts for immutable structs? (lambda (val) (unless (predicate?-name val) (raise-contract-error + val src-info pos neg @@ -1083,6 +1084,7 @@ add struct contracts for immutable structs? (predicate?-name v)) (constructor-name (p-apps (selector-names v)) ...) (raise-contract-error + v src-info pos neg @@ -1116,6 +1118,7 @@ add struct contracts for immutable structs? (cons (p-app (selector-name v i)) (loop (cdr p-apps) (+ i 1))))]))) (raise-contract-error + v src-info pos neg @@ -1186,6 +1189,7 @@ add struct contracts for immutable structs? (lambda (val) (unless (promise? val) (raise-contract-error + val src-info pos neg @@ -1239,6 +1243,7 @@ add struct contracts for immutable structs? (lambda (val) (unless (predicate-id val) (raise-contract-error + val src-info pos neg