fixed more calls to error (that should be raise-argument-error) in the contract library

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)))

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

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))
+  (unless (member immutable '(#t #f dont-care))
-    (error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable))
+    (raise-argument-error 'hash/c
-  (let ([dom-ctc (if flat?
+                          "(or/c #t #f 'dont-care) for the #:immutable argument"
-                     (coerce-flat-contract 'hash/c dom)
+                          immutable))
-                     (coerce-contract 'hash/c dom))]
+  (define dom-ctc (if flat?
-        [rng-ctc (if flat?
+                      (coerce-flat-contract 'hash/c dom)
-                     (coerce-flat-contract 'hash/c rng)
+                      (coerce-chaperone-contract 'hash/c dom)))
-                     (coerce-contract 'hash/c rng))])
+  (define rng-ctc (if flat?
-    (unless (chaperone-contract? dom-ctc)
+                      (coerce-flat-contract 'hash/c rng)
-      (error 'hash/c "expected either a flat or chaperone contract for the domain, got ~s" (contract-name dom-ctc)))
+                      (coerce-contract 'hash/c rng)))
-    (cond
+  (cond
-      [(or flat?
+    [(or flat?
-           (and (eq? immutable #t)
+         (and (eq? immutable #t)
-                (flat-contract? dom-ctc)
+              (flat-contract? dom-ctc)
-                (flat-contract? rng-ctc)))
+              (flat-contract? rng-ctc)))
-       (make-flat-hash/c dom-ctc rng-ctc immutable)]
+     (make-flat-hash/c dom-ctc rng-ctc immutable)]
-      [(chaperone-contract? rng-ctc)
+    [(chaperone-contract? rng-ctc)
-       (make-chaperone-hash/c dom-ctc rng-ctc immutable)]
+     (make-chaperone-hash/c dom-ctc rng-ctc immutable)]
-      [else
+    [else
-       (make-impersonator-hash/c dom-ctc rng-ctc immutable)])))
+     (make-impersonator-hash/c dom-ctc rng-ctc immutable)]))
 
 (define (check-hash/c ctc val blame) 
   (define dom-ctc (base-hash/c-dom ctc))

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
+     (raise-argument-error 
-            "expected a projection that accepts 4 or 5 arguments; got: ~e"
+      'make-proj-contract
-            proj)])))
+      (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
+    (raise-argument-error 'contract
-           "expected a syntax object or list of two elements, got: ~e"
+                          (format "~s" '(or/c syntax?
-           info)]))
+                                              (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
+    (raise-argument-error 'contract
-           "expected a syntax object or list of two elements, got: ~e"
+                          (format "~s" '(or/c syntax?
-           info)]))
+                                              (list/c any/c any/c)))
+                          info)]))

collects/racket/contract/private/object.rkt

@@ -87,38 +87,48 @@
 
 (define (subclass?/c %)
   (unless (class? %)
-    (error 'subclass?/c "expected <class>, given: ~e" %))
+    (raise-argument-error 'subclass?/c
-  (let ([name (object-name %)])
+                          'class?
-    (flat-named-contract
+                          %))
-     `(subclass?/c ,(or name 'unknown%))
+  (define name (object-name %))
-     (lambda (x) (subclass? x %)))))
+  (flat-named-contract
+   `(subclass?/c ,(or name 'unknown%))
+   (lambda (x) (subclass? x %))))
 
 (define (implementation?/c <%>)
   (unless (interface? <%>)
-    (error 'implementation?/c "expected <interface>, given: ~e" <%>))
+    (raise-argument-error 'implementation?/c
-  (let ([name (object-name <%>)])
+                          'interface?
-    (flat-named-contract
+                          <%>))
-     `(implementation?/c ,(or name 'unknown<%>))
+  (define name (object-name <%>))
-     (lambda (x) (implementation? x <%>)))))
+  (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? <%>)
+  (unless (or (interface? <%>) (class? <%>))
-              (class? <%>))
+    (raise-argument-error
-    (error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
+     'is-a?/c
-  (let ([name (object-name <%>)])
+     (format "~s" '(or/c interface? class?))
-    (flat-named-contract
+     <%>))
-     (cond
+  (define name (object-name <%>))
-       [name
+  (flat-named-contract
-        `(is-a?/c ,name)]
+   (cond
-       [(class? <%>)
+     [name
-        `(is-a?/c unknown%)]
+      `(is-a?/c ,name)]
-       [else `(is-a?/c unknown<%>)])
+     [(class? <%>)
-     (lambda (x) (is-a? x <%>)))))
+      `(is-a?/c unknown%)]
+     [else `(is-a?/c unknown<%>)])
+   (lambda (x) (is-a? x <%>))))
 
 (define mixin-contract (->d ([c% class?]) () [res (subclass?/c c%)]))

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" 
+       (raise-argument-error 'struct/dc
-              (subcontract-field-name subcontract)
+                             (format "a flat-contract? for field ~a" (subcontract-field-name subcontract))
-              (contract-name dep-ctc)))]
+                             dep-ctc))]
     [(#:chaperone)
      (unless (chaperone-contract? dep-ctc)
-       (error 'struct/dc "expected a chaperone contract for the field: ~a, got ~s" 
+       (raise-argument-error 'struct/dc
-              (subcontract-field-name subcontract)
+                             (format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract))
-              (contract-name dep-ctc)))]))
+                             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"
+        (raise-argument-error 'struct/dc
-               (subcontract-field-name subcontract)
+                             (format "a chaperone-contract? for field ~a" (subcontract-field-name subcontract))
-               (indep-ctc subcontract)))))
+                             (indep-ctc subcontract)))))
   (define (flat-subcontract? subcontract)
     (cond
       [(indep? subcontract) (flat-contract? (indep-ctc subcontract))]

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