From 6e4d4834031ce1d71db8f52746dbe14380851e84 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 23 Mar 2013 13:39:17 -0500
Subject: [PATCH] adjust contract library to call raise-argument-error instead
 of error

and a few other changes nearby to clean up various things

closes PR 13623
---
 collects/racket/contract/private/guts.rkt     |  76 ++++-----
 collects/racket/contract/private/misc.rkt     | 151 +++++++-----------
 .../scribblings/reference/contracts.scrbl     |   2 +-
 collects/tests/racket/contract-test.rktl      |   5 +-
 4 files changed, 101 insertions(+), 133 deletions(-)

diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt
index e6b5e5dde9..b463135a9b 100644
--- a/collects/racket/contract/private/guts.rkt
+++ b/collects/racket/contract/private/guts.rkt
@@ -88,54 +88,54 @@
 
 ;; coerce-flat-contract : symbol any/c -> contract
 (define (coerce-flat-contract name x)
-  (let ([ctc (coerce-contract/f x)])
-    (unless (flat-contract-struct? ctc)
-      (error name 
-             "expected a flat contract or a value that can be coerced into one, got ~e"
-             x))
-    ctc))
+  (define ctc (coerce-contract/f x))
+  (unless (flat-contract-struct? ctc)
+    (raise-argument-error name 'flat-contract? x))
+  ctc)
 
 ;; coerce-flat-contacts : symbol (listof any/c) -> (listof flat-contract)
 ;; like coerce-contracts, but insists on flat-contracts
 (define (coerce-flat-contracts name xs) 
   (for/list ([x (in-list xs)]
              [i (in-naturals)])
-    (let ([ctc (coerce-contract/f x)])
-      (unless (flat-contract-struct? ctc)
-        (error name
-               "expected all of the arguments to be flat contracts, but argument ~a was not, got ~e"
-               i
-               x))
-      ctc)))
+    (define ctc (coerce-contract/f x))
+    (unless (flat-contract-struct? ctc)
+      (raise-argument-error name
+                            'flat-contract?
+                            i 
+                            xs))
+    ctc))
 
 ;; coerce-chaperone-contract : symbol any/c -> contract
 (define (coerce-chaperone-contract name x)
-  (let ([ctc (coerce-contract/f x)])
-    (unless (chaperone-contract-struct? ctc)
-      (error name
-             "expected a chaperone contract or a value that can be coerced into one, got ~e"
-             x))
-    ctc))
+  (define ctc (coerce-contract/f x))
+  (unless (chaperone-contract-struct? ctc)
+    (raise-argument-error
+     name
+     'chaperone-contract?
+     x))
+  ctc)
 
 ;; coerce-chaperone-contacts : symbol (listof any/c) -> (listof flat-contract)
 ;; like coerce-contracts, but insists on chaperone-contracts
 (define (coerce-chaperone-contracts name xs)
   (for/list ([x (in-list xs)]
              [i (in-naturals)])
-    (let ([ctc (coerce-contract/f x)])
-      (unless (chaperone-contract-struct? ctc)
-        (error name
-               "expected all of the arguments to be chaperone contracts, but argument ~a was not, got ~e"
-               i
-               x))
-      ctc)))
+    (define ctc (coerce-contract/f x))
+    (unless (chaperone-contract-struct? ctc)
+      (apply raise-argument-error
+             name
+             'chaperone-contract?
+             i
+             xs))
+    ctc))
 
 ;; coerce-contract : symbol any/c -> contract
 (define (coerce-contract name x)
   (or (coerce-contract/f x)
-      (error name 
-             "expected contract or a value that can be coerced into one, got ~e"
-             x)))
+      (raise-argument-error name
+                            'contract?
+                            x)))
 
 ;; coerce-contracts : symbols (listof any) -> (listof contract)
 ;; turns all of the arguments in 'xs' into contracts
@@ -144,13 +144,14 @@
 (define (coerce-contracts name xs)
   (for/list ([x (in-list xs)]
              [i (in-naturals)])
-    (let ([ctc (coerce-contract/f x)])
-      (unless ctc
-        (error name
-              "expected all of the arguments to be contracts, but argument ~a was not, got ~e"
-              i
-              x))
-      ctc)))
+    (define ctc (coerce-contract/f x))
+    (unless ctc
+      (apply raise-argument-error
+             name
+             "contract?"
+             i
+             xs))
+    ctc))
 
 ;; coerce-contract/f : any -> (or/c #f contract?)
 ;; returns #f if the argument could not be coerced to a contract
@@ -271,7 +272,8 @@
    #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
    #:name
    (λ (ctc) 
-      (if (symbol? (eq-contract-val ctc))
+      (if (or (null? (eq-contract-val ctc))
+              (symbol? (eq-contract-val ctc)))
         `',(eq-contract-val ctc)
         (eq-contract-val ctc)))
    #:generate
diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt
index 442dcfcce1..96503a51ae 100644
--- a/collects/racket/contract/private/misc.rkt
+++ b/collects/racket/contract/private/misc.rkt
@@ -59,12 +59,9 @@
      (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
                    [(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
        (syntax 
-        (let* ([pred (λ (x) (error 'flat-rec-contract "applied too soon"))]
+        (let* ([pred flat-rec-contract/init]
                [name (flat-contract (let ([name (λ (x) (pred x))]) name))])
-          (let ([ctc-id (coerce-contract 'flat-rec-contract ctc)] ...)
-            (unless (flat-contract? ctc-id)
-              (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
-            ...
+          (let ([ctc-id (coerce-flat-contract 'flat-rec-contract ctc)] ...)
             (set! pred
                   (let ([pred-id (flat-contract-predicate ctc-id)] ...)
                     (λ (x)
@@ -73,6 +70,8 @@
     [(_ name ctc ...)
      (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))]))
 
+(define (flat-rec-contract/init x) (error 'flat-rec-contract "applied too soon"))
+
 (define-syntax (flat-murec-contract stx)
   (syntax-case stx  ()
     [(_ ([name ctc ...] ...) body1 body ...)
@@ -83,14 +82,9 @@
                    [((pred-arm-id ...) ...) (map generate-temporaries
                                                  (syntax->list (syntax ((ctc ...) ...))))])
        (syntax 
-        (let* ([pred-id (λ (x) (error 'flat-murec-contract "applied too soon"))] ...
+        (let* ([pred-id flat-murec-contract/init] ...
                [name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...)
-          (let-values ([(ctc-id ...) (values (coerce-contract 'flat-rec-contract ctc) ...)] ...)
-            (begin
-              (void)
-              (unless (flat-contract? ctc-id)
-                (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
-              ...) ...
+          (let-values ([(ctc-id ...) (values (coerce-flat-contract 'flat-rec-contract ctc) ...)] ...)
             (set! pred-id
                   (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
                     (λ (x)
@@ -106,6 +100,8 @@
     [(_ ([name ctc ...] ...))
      (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)]))
 
+(define (flat-murec-contract/init x) (error 'flat-murec-contract "applied too soon"))
+
 (define/subexpression-pos-prop or/c
   (case-lambda 
     [() (make-none/c '(or/c))]
@@ -421,20 +417,23 @@
 (define false/c #f)
 
 (define/final-prop (string-len/c n)
-  (unless (number? n)
-    (error 'string-len/c "expected a number as argument, got ~e" n))
+  (unless (real? n)
+    (raise-argument-error 'string-len/c "real?" n))
   (flat-named-contract 
    `(string-len/c ,n)
    (λ (x)
      (and (string? x)
           ((string-length x) . < . n)))))
 
-(define/final-prop (symbols . ss)
-  (unless ((length ss) . >= . 1)
-    (error 'symbols "expected at least one argument"))
-  (unless (andmap symbol? ss)
-    (error 'symbols "expected symbols as arguments, given: ~a"
-           (apply string-append (map (λ (x) (format "~e " x)) ss))))
+(define/final-prop (symbols s1 . s2s)
+  (define ss (cons s1 s2s))
+  (for ([arg (in-list ss)]
+        [i (in-naturals)])
+    (unless (symbol? arg)
+      (raise-argument-error 'symbols
+                            "symbol?"
+                            i
+                            ss)))
   (apply or/c ss))
 
 (define atomic-value? 
@@ -445,54 +444,22 @@
           (void? x) (eq? x undefined)))))
 
 (define/final-prop (one-of/c . elems)
-  (unless (andmap atomic-value? elems)
-    (error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e"
-           elems))
-  (if (or (member (void) elems)
-          (member (letrec ([x x]) x) elems))
-      (make-one-of/c elems)
-      (apply or/c elems)))
-
-(define (one-of-pc x)
-  (cond
-    [(symbol? x)
-     `',x]
-    [(null? x)
-     ''()]
-    [(void? x)
-     '(void)]
-    [(or (char? x) 
-         (boolean? x)
-         (keyword? x)
-         (number? x))
-     x]
-    [(eq? x (letrec ([x x]) x))
-     '(letrec ([x x]) x)]
-    [else (error 'one-of-pc "undef ~s" x)]))
-
-
-(define-struct one-of/c (elems)
-  #:omit-define-syntaxes
-  #:property prop:flat-contract
-  (build-flat-contract-property
-   #:name
-   (λ (ctc) 
-      (let ([elems (one-of/c-elems ctc)])
-        `(one-of/c ,@(map one-of-pc elems))))
-
-   #:stronger
-   (λ (this that)
-      (and (one-of/c? that)
-           (let ([this-elems (one-of/c-elems this)]
-                 [that-elems (one-of/c-elems that)])
-             (and 
-              (andmap (λ (this-elem) (memv this-elem that-elems))
-                      this-elems)
-              #t))))
-   #:first-order 
-   (λ (ctc) 
-      (let ([elems (one-of/c-elems ctc)])
-        (λ (x) (memv x elems))))))
+  (for ([arg (in-list elems)]
+        [i (in-naturals)])
+    (unless (atomic-value? arg)
+      (raise-argument-error 'one-of/c
+                            "char, symbol, boolean, null, keyword, number, void, or undefined"
+                            i
+                            elems)))
+  (define (undefined? x) (eq? x (letrec ([x x]) x)))
+  (define or/c-args
+    (map (λ (x)
+           (cond
+             [(void? x) void?]
+             [(undefined? x) undefined?]
+             [else x]))
+         elems))
+  (apply or/c or/c-args))
 
 (define-struct between/c (low high)
   #:omit-define-syntaxes
@@ -537,13 +504,9 @@
            (+ (random (- upper lower))
               lower))))))
 
-(define-syntax (check-unary-between/c stx)
-  (syntax-case stx ()
-    [(_ 'sym x-exp)
-     (identifier? #'sym)
-     #'(let ([x x-exp])
-         (unless (real? x)
-           (error 'sym "expected a real number, got ~e" x)))]))
+(define (check-unary-between/c sym x)
+  (unless (real? x)
+    (raise-argument-error sym "real?" x)))
 
 (define/final-prop (=/c x) 
   (check-unary-between/c '=/c x)
@@ -555,15 +518,11 @@
   (check-unary-between/c '>=/c x)
   (make-between/c x +inf.0))
 (define (check-between/c x y)
-  (unless (real? x)
-    (error 'between/c "expected a real number as first argument, got ~e, other arg ~e" x y))
-  (unless (real? y)
-    (error 'between/c "expected a real number as second argument, got ~e, other arg ~e" y x)))
+  (check-two-args 'between/c x y real? real?))
 (define/final-prop (between/c x y)
   (check-between/c x y)
   (make-between/c x y))
 
-
 (define (</c x)
   (flat-named-contract
    `(</c ,x)
@@ -590,23 +549,27 @@
          (+ (random (- max-n lower))
             lower)))))
 
+(define (check-two-args name arg1 arg2 pred1? pred2?)
+  (unless (pred1? arg1)
+    (raise-argument-error name
+                          (format "~a" (object-name pred1?))
+                          0
+                          (list arg1 arg2)))
+  (unless (pred2? arg2)
+    (raise-argument-error name
+                          (format "~a" (object-name pred2?))
+                          1
+                          (list arg1 arg2))))
 (define/final-prop (integer-in start end)
-  (unless (and (integer? start)
-               (exact? start)
-               (integer? end)
-               (exact? end))
-    (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end))
+  (check-two-args 'integer-in start end exact-integer? exact-integer?)
   (flat-named-contract 
    `(integer-in ,start ,end)
    (λ (x)
-     (and (integer? x)
-          (exact? x)
+     (and (exact-integer? x)
           (<= start x end)))))
 
 (define/final-prop (real-in start end)
-  (unless (and (real? start)
-               (real? end))
-    (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end))
+  (check-two-args 'real start end real? real?)
   (between/c start end))
 
 (define/final-prop (not/c f)
@@ -1166,9 +1129,11 @@
       [(flat-contract? predicate)
        (make-predicate-contract name (flat-contract-predicate predicate) generate)]
       [else
-       (error 'flat-named-contract 
-              "expected a flat contract or procedure of arity 1 as second argument, got ~e" 
-              predicate)])))
+       (raise-argument-error 'flat-named-contract
+                             (format "~s" `(or/c flat-contract?
+                                                 (and/c procedure?
+                                                        (λ (x) (procedure-arity-include? x 1)))))
+                             predicate)])))
 
 (define printable/c
   (flat-named-contract
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 336be3eb63..9e4660b525 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -240,7 +240,7 @@ between @racket[j] and @racket[k], inclusive.}
 A flat contract that requires the input to be an exact non-negative integer.}
 
 
-@defproc[(string-len/c [len exact-nonnegative-integer?]) flat-contract?]{
+@defproc[(string-len/c [len real?]) flat-contract?]{
 
 Returns a flat contract that recognizes strings that have fewer than
 @racket[len] characters.}
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 59c2758e4e..89069698ba 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -9639,7 +9639,7 @@
 
   (test/no-error '(syntax/c (list/c #f)))
   (contract-error-test 'syntax/c-non-flat '(syntax/c (vector/c #f))
-                       (λ (x) (regexp-match #rx"expected a flat contract" (exn-message x))))
+                       (λ (x) (regexp-match? #rx"flat-contract[?]" (exn-message x))))
 
 
 ;
@@ -12251,6 +12251,7 @@ so that propagation occurs.
   (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?))
 
   (test-name '(or/c) (or/c))
+  (test-name '(or/c '()) (or/c '()))
   (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
   (test-name '(or/c integer? boolean?)
              (or/c (flat-contract integer?)
@@ -12303,7 +12304,7 @@ so that propagation occurs.
   (test-name 'printable/c printable/c)
   (test-name '(or/c 'a 'b 'c) (symbols 'a 'b 'c))
   (test-name '(or/c 1 2 3) (one-of/c 1 2 3))
-  (test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))
+  (test-name '(or/c '() 'x 1 #f #\a void? undefined?)
              (one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)))
 
   (test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x"))