..

original commit: d14cfb79aa467931c0d1e79d828b2b7f338e3d6f

collects/mzlib/contracts.ss

@@ -142,10 +142,12 @@
 
   ;; flat-named-contract = (make-flat-named-contract string (any -> boolean))
   ;; this holds flat contracts that have names for error reporting
-  (define-struct flat-named-contract (type-name predicate))
+  (define-struct flat-named-contract (type-name predicate) (make-inspector)) (print-struct #t)
+
   (provide (rename build-flat-named-contract flat-named-contract)
            flat-named-contract-type-name
            flat-named-contract-predicate)
+  
   (define build-flat-named-contract
     (let ([flat-named-contract
 	   (lambda (name contract)
@@ -693,24 +695,36 @@
             pos
 	    neg
             "~agiven: ~e~a"
-	    (predicate->type-name contract)
+	    (predicate->expected-msg contract)
 	    val
             (if extra-message
                 extra-message
                 "")))]))
 
-  ;; predicate->type-name : function -> string
+  ;; predicate->expected-msg : function -> string
   ;; if the function has a name and the name ends
   ;; with a question mark, turn it into a mzscheme
   ;; style type name
+  (define (predicate->expected-msg pred)
+    (let ([name (predicate->type-name)])
+      (if name
+          (format "expected type <~a>, " name)
+          "")))
+  
+  ;; predicate->type-name : pred -> (union #f string)
   (define (predicate->type-name pred)
     (let* ([name (object-name pred)])
-      (if name
+      (and name
            (let ([m (regexp-match "(.*)\\?" (symbol->string name))])
-	    (if m
+             (and m
-		(format "expected type <~a>, " (cadr m))
+                  (cadr m))))))
-		""))
+
-	  "")))
+  ;; flat-contract->type-name : flat-contract -> string
+  (define (flat-contract->type-name fc)
+    (cond
+      [(flat-named-contract? fc) (flat-named-contract-type-name fc)]
+      [else (or (predicate->type-name fc)
+                "unknown type")]))
 
   (provide union)
   (define (union . args)
@@ -732,6 +746,14 @@
       (unless (or (null? contracts)
                   (null? (cdr contracts)))
         (error 'union "expected at most one function contract, given: ~e" args))
+      (cond
+        [(null? contracts) 
+         (make-flat-named-contract
+          (apply build-compound-type-name "union" procs)
+          (lambda (x)
+            (ormap (lambda (proc) (test-flat-contract proc x))
+                    procs)))]
+        [else
          (make-contract
           (lambda (val pos neg src-info)
             (cond
@@ -744,7 +766,7 @@
               [(null? contracts)
                (raise-contract-error src-info pos neg "union failed, given: ~e" val)]
               [(null? (cdr contracts))
-            ((contract-f (car contracts)) val pos neg src-info)])))))
+               ((contract-f (car contracts)) val pos neg src-info)])))])))
 
   (provide and/f or/f 
            >=/c <=/c </c >/c 
@@ -753,9 +775,37 @@
 	   printable?
            symbols
            subclass?/c implementation?/c is-a?/c
-           listof vectorof cons/p list/p
+           listof vectorof vector/p cons/p list/p box/p
 	   mixin-contract make-mixin-contract)
 
+  ;; test-flat-contract : (union pred flat-named-contract) any -> boolean
+  (define (test-flat-contract flat-contract x)
+    (cond
+      [(flat-named-contract? flat-contract)
+       ((flat-named-contract-predicate flat-contract) x)]
+      [else
+       (flat-contract x)]))
+
+  
+  ;; flat-contract? : any -> boolean?
+  ;; determines if a value is a flat contract
+  (define (flat-contract? fc)
+    (or (flat-named-contract? fc)
+	(and (procedure? fc)
+	     (procedure-arity-includes? fc 1))))
+
+  (define (build-compound-type-name name . fs)
+    (let ([strs (map flat-contract->type-name fs)])
+      (format "(~a~a)" 
+              name
+              (apply string-append
+                     (let loop ([strs strs])
+                       (cond
+                         [(null? strs) null]
+                         [else (cons " "
+                                     (cons (car strs)
+                                           (loop (cdr strs))))]))))))
+  
   (define (symbols . ss)
     (unless ((length ss) . >= . 1)
       (error 'symbols "expected at least one argument"))
@@ -769,7 +819,11 @@
      (lambda (x)
        (memq x ss))))
 
-  (define (printable? x)
+  (define printable?
+    (make-flat-named-contract
+     "printable"
+     (lambda (x)
+       (let printable? ([x x])
 	 (or (symbol? x)
 	     (string? x)
 	     (boolean? x)
@@ -782,7 +836,7 @@
 	     (and (vector? x)
 		  (andmap printable? (vector->list x)))
 	     (and (box? x)
-	     (printable? (unbox x)))))
+		  (printable? (unbox x))))))))
 
   (define (and/f . fs)
     (for-each
@@ -792,12 +846,11 @@
                         (procedure-arity-includes? x 1)))
          (error 'and/f "expected procedures of arity 1 or <flat-named-contract>s, given: ~e" x)))
      fs)
+    (make-flat-named-contract
+     (apply build-compound-type-name "and/f" fs)
      (lambda (x)
-      (andmap (lambda (f) 
+       (andmap (lambda (f) (test-flat-contract f x))
-                (if (flat-named-contract? f)
+               fs))))
-                    ((flat-named-contract-predicate f) x)
-                    (f x)))
-              fs)))
 
   (define (or/f . fs)
     (for-each
@@ -807,12 +860,11 @@
                         (procedure-arity-includes? x 1)))
          (error 'or/f "expected procedures of arity 1 or <flat-named-contract>s, given: ~e" x)))
      fs)
+    (make-flat-named-contract
+     (apply build-compound-type-name "or/f" fs)
      (lambda (x)
-      (ormap (lambda (f)
+       (ormap (lambda (f) (test-flat-contract f x))
-               (if (flat-named-contract? f)
+              fs))))
-                   ((flat-named-contract-predicate f) x)
-                   (f x)))
-             fs)))
   
   (define (>=/c x)
     (make-flat-named-contract
@@ -831,10 +883,13 @@
      (format "number > ~a" x)
      (lambda (y) (and (number? y) (> y x)))))
 
-  (define (natural-number? x)
+  (define natural-number?
+    (make-flat-named-contract
+     "natural-number"
+     (lambda (x)
        (and (number? x)
 	    (integer? x)
-	 (x . >= . 0)))
+	    (x . >= . 0)))))
 
   (define (is-a?/c <%>)
     (unless (or (interface? <%>)
@@ -867,26 +922,85 @@
 	   "implementation of <<unknown>>")
        (lambda (x) (implementation? x <%>)))))
 
-  (define (false? x) (not x))
+  (define false?
-  (define (any? x) #t)
+    (make-flat-named-contract
+     "false"
+     (lambda (x) (not x))))
+
+  (define any?
+    (make-flat-named-contract
+     "any"
+     (lambda (x) #t)))
 
   (define (listof p)
+    (unless (flat-contract? p)
+      (error 'listof "expected a flat contract as argument, got: ~e" p))
+    (make-flat-named-contract
+     (build-compound-type-name "listof" p)
      (lambda (v)
        (and (list? v)
-	   (andmap p v))))
+	    (andmap (lambda (ele) (test-flat-contract p ele))
+		    v)))))
   
   (define (vectorof p)
+    (unless (flat-contract? p)
+      (error 'vectorof "expected a flat contract as argument, got: ~e" p))
+    (make-flat-named-contract
+     (build-compound-type-name "vectorof" p)
      (lambda (v)
        (and (vector? v)
-	   (andmap p (vector->list v)))))
+	    (andmap (lambda (ele) (test-flat-contract p ele))
+		    (vector->list v))))))
+
+  (define (vector/p . args)
+    (unless (andmap flat-contract? args)
+      (error 'vector/p "expected flat contracts as arguments, got: ~a"
+             (let loop ([args args])
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
+    (make-flat-named-contract
+     (apply build-compound-type-name "vector/p" args)
+     (lambda (v)
+       (and (vector? v)
+            (= (vector-length v) (length args))
+            (andmap test-flat-contract
+                    args
+                    (vector->list v))))))
+  
+  (define (box/p pred)
+    (unless (flat-contract? pred)
+      (error 'box/p "expected a flat contract, got: ~e" pred))
+    (make-flat-named-contract
+     (build-compound-type-name "box/p" pred)
+     (lambda (x)
+       (and (box? x)
+	    (test-flat-contract pred (unbox x))))))
 
   (define (cons/p hdp tlp)
+    (unless (and (flat-contract? hdp)
+                 (flat-contract? tlp))
+      (error 'cons/p "expected two flat contracts, got: ~e and ~e" hdp tlp))
+    (make-flat-named-contract
+     (build-compound-type-name "cons/p" hdp tlp)
      (lambda (x)
        (and (pair? x)
-	   (hdp (car x))
+            (test-flat-contract hdp (car x))
-	   (tlp (cdr x)))))
+            (test-flat-contract tlp (cdr x))))))
 
   (define (list/p . args)
+    (unless (andmap flat-contract? args)
+      (error 'list/p "expected flat contracts, got: ~a"
+             (let loop ([args args])
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
     (let loop ([args args])
       (cond
 	[(null? args) null?]