From 57f857b45afff339a1279e9bed23c32606b2a6b4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 24 Mar 2013 08:08:18 -0500 Subject: [PATCH] fixed more calls to error (that should be raise-argument-error) in the contract library --- collects/racket/contract/private/arrow.rkt | 2 +- collects/racket/contract/private/ds.rkt | 4 +- collects/racket/contract/private/hash.rkt | 40 ++++++------- collects/racket/contract/private/legacy.rkt | 27 +++++---- collects/racket/contract/private/object.rkt | 56 +++++++++++-------- .../racket/contract/private/struct-dc.rkt | 18 +++--- collects/tests/racket/contract-test.rktl | 2 +- 7 files changed, 83 insertions(+), 66 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index ff68a8ea4a..37722f7836 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -573,7 +573,7 @@ v4 todo: (λ args ; Make sure that the args match the contract (begin (unless ((contract-struct-exercise ctc) args (/ fuel 2)) - (error "Arg(s) ~a do(es) not match contract ~a\n" ctc)) + (error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc)) ; Stash the valid value ;(env-stash (generate-env) ctc args) (apply values rngs-gens))) diff --git a/collects/racket/contract/private/ds.rkt b/collects/racket/contract/private/ds.rkt index dba2490847..f930be2212 100644 --- a/collects/racket/contract/private/ds.rkt +++ b/collects/racket/contract/private/ds.rkt @@ -306,7 +306,9 @@ it around flattened out. (do-selection struct (+ i 1)) (wrap-get struct (+ i 1)))] [else - (error selector-name "expected: ~s, got ~e" 'name struct)])) + (raise-argument-error selector-name + 'name + struct)])) (define (lazy-contract-name ctc) (do-contract-name 'struct/c diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt index 1fe4e68be4..454710b4cf 100644 --- a/collects/racket/contract/private/hash.rkt +++ b/collects/racket/contract/private/hash.rkt @@ -55,26 +55,26 @@ (vector this-one (list #'h/c) null))))])) (define (hash/c dom rng #:immutable [immutable 'dont-care] #:flat? [flat? #f]) - (unless (memq immutable '(#t #f dont-care)) - (error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable)) - (let ([dom-ctc (if flat? - (coerce-flat-contract 'hash/c dom) - (coerce-contract 'hash/c dom))] - [rng-ctc (if flat? - (coerce-flat-contract 'hash/c rng) - (coerce-contract 'hash/c rng))]) - (unless (chaperone-contract? dom-ctc) - (error 'hash/c "expected either a flat or chaperone contract for the domain, got ~s" (contract-name dom-ctc))) - (cond - [(or flat? - (and (eq? immutable #t) - (flat-contract? dom-ctc) - (flat-contract? rng-ctc))) - (make-flat-hash/c dom-ctc rng-ctc immutable)] - [(chaperone-contract? rng-ctc) - (make-chaperone-hash/c dom-ctc rng-ctc immutable)] - [else - (make-impersonator-hash/c dom-ctc rng-ctc immutable)]))) + (unless (member immutable '(#t #f dont-care)) + (raise-argument-error 'hash/c + "(or/c #t #f 'dont-care) for the #:immutable argument" + immutable)) + (define dom-ctc (if flat? + (coerce-flat-contract 'hash/c dom) + (coerce-chaperone-contract 'hash/c dom))) + (define rng-ctc (if flat? + (coerce-flat-contract 'hash/c rng) + (coerce-contract 'hash/c rng))) + (cond + [(or flat? + (and (eq? immutable #t) + (flat-contract? dom-ctc) + (flat-contract? rng-ctc))) + (make-flat-hash/c dom-ctc rng-ctc immutable)] + [(chaperone-contract? rng-ctc) + (make-chaperone-hash/c dom-ctc rng-ctc immutable)] + [else + (make-impersonator-hash/c dom-ctc rng-ctc immutable)])) (define (check-hash/c ctc val blame) (define dom-ctc (base-hash/c-dom ctc)) diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt index 77ea443dff..4ebdb5b4d3 100644 --- a/collects/racket/contract/private/legacy.rkt +++ b/collects/racket/contract/private/legacy.rkt @@ -38,9 +38,12 @@ (list (blame-source blame) (blame-value blame)) (blame-contract blame)))] [else - (error 'make-proj-contract - "expected a projection that accepts 4 or 5 arguments; got: ~e" - proj)]))) + (raise-argument-error + 'make-proj-contract + (format "~s" '(and/c procedure? + (λ (x) (or/c (procedure-arity-includes? x 4) + (procedure-arity-includes? x 5))))) + proj)]))) (define (contract-proc c) (let* ([proj (contract-projection c)]) @@ -71,7 +74,7 @@ (define (unpack-source info) (cond [(syntax? info) (build-source-location info)] - [(list? info) + [(and (list? info) (= 2 (length info))) (let ([loc (list-ref info 0)]) (if (syntax? (srcloc-source loc)) (struct-copy @@ -83,15 +86,17 @@ (srcloc-source loc))))]) loc))] [else - (error 'contract - "expected a syntax object or list of two elements, got: ~e" - info)])) + (raise-argument-error 'contract + (format "~s" '(or/c syntax? + (list/c any/c any/c))) + info)])) (define (unpack-name info) (cond [(syntax? info) (and (identifier? info) (syntax-e info))] - [(list? info) (list-ref info 1)] + [(and (list? info) (= 2 (length info))) (list-ref info 1)] [else - (error 'contract - "expected a syntax object or list of two elements, got: ~e" - info)])) + (raise-argument-error 'contract + (format "~s" '(or/c syntax? + (list/c any/c any/c))) + info)])) diff --git a/collects/racket/contract/private/object.rkt b/collects/racket/contract/private/object.rkt index 2b92f624f6..d13e707b62 100644 --- a/collects/racket/contract/private/object.rkt +++ b/collects/racket/contract/private/object.rkt @@ -87,38 +87,48 @@ (define (subclass?/c %) (unless (class? %) - (error 'subclass?/c "expected , given: ~e" %)) - (let ([name (object-name %)]) - (flat-named-contract - `(subclass?/c ,(or name 'unknown%)) - (lambda (x) (subclass? x %))))) + (raise-argument-error 'subclass?/c + 'class? + %)) + (define name (object-name %)) + (flat-named-contract + `(subclass?/c ,(or name 'unknown%)) + (lambda (x) (subclass? x %)))) (define (implementation?/c <%>) (unless (interface? <%>) - (error 'implementation?/c "expected , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - `(implementation?/c ,(or name 'unknown<%>)) - (lambda (x) (implementation? x <%>))))) + (raise-argument-error 'implementation?/c + 'interface? + <%>)) + (define name (object-name <%>)) + (flat-named-contract + `(implementation?/c ,(or name 'unknown<%>)) + (lambda (x) (implementation? x <%>)))) (define (sub/impl?/c %/<%>) (cond [(interface? %/<%>) (implementation?/c %/<%>)] [(class? %/<%>) (subclass?/c %/<%>)] - [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) + [else + (raise-argument-error + 'make-mixin-contract + (format "~s" '(or/c interface? class?)) + %/<%>)])) (define (is-a?/c <%>) - (unless (or (interface? <%>) - (class? <%>)) - (error 'is-a?/c "expected or , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - (cond - [name - `(is-a?/c ,name)] - [(class? <%>) - `(is-a?/c unknown%)] - [else `(is-a?/c unknown<%>)]) - (lambda (x) (is-a? x <%>))))) + (unless (or (interface? <%>) (class? <%>)) + (raise-argument-error + 'is-a?/c + (format "~s" '(or/c interface? class?)) + <%>)) + (define name (object-name <%>)) + (flat-named-contract + (cond + [name + `(is-a?/c ,name)] + [(class? <%>) + `(is-a?/c unknown%)] + [else `(is-a?/c unknown<%>)]) + (lambda (x) (is-a? x <%>)))) (define mixin-contract (->d ([c% class?]) () [res (subclass?/c c%)])) diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index 00bfa082eb..a2af9a0bdc 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -393,14 +393,14 @@ (case (dep-type subcontract) [(#:flat) (unless (flat-contract? dep-ctc) - (error 'struct/dc "expected a flat contract for the field: ~a, got ~s" - (subcontract-field-name subcontract) - (contract-name dep-ctc)))] + (raise-argument-error 'struct/dc + (format "a flat-contract? for field ~a" (subcontract-field-name subcontract)) + dep-ctc))] [(#:chaperone) (unless (chaperone-contract? dep-ctc) - (error 'struct/dc "expected a chaperone contract for the field: ~a, got ~s" - (subcontract-field-name subcontract) - (contract-name dep-ctc)))])) + (raise-argument-error 'struct/dc + (format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract)) + dep-ctc))])) (define (struct/dc-stronger? this that) (and (base-struct/dc? that) @@ -463,9 +463,9 @@ (when (and (indep? subcontract) (not (mutable? subcontract))) (unless (chaperone-contract? (indep-ctc subcontract)) - (error 'struct/dc "expected chaperone contracts, but field ~a has ~e" - (subcontract-field-name subcontract) - (indep-ctc subcontract))))) + (raise-argument-error 'struct/dc + (format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract)) + (indep-ctc subcontract))))) (define (flat-subcontract? subcontract) (cond [(indep? subcontract) (flat-contract? (indep-ctc subcontract))] diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 89069698ba..25d8af4368 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -10613,7 +10613,7 @@ (struct/dc s [ernie integer?] [bert (new-∀/c 'α)])) (λ (x) (and (exn:fail? x) - (regexp-match #rx"expected chaperone" (exn-message x))))) + (regexp-match #rx"chaperone-contract[?]" (exn-message x))))) (contract-error-test 'struct/dc-not-a-field