From 3028f2d1424123d076a95572a7564b8fb069a86e Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 17 May 2010 13:11:10 -0400
Subject: [PATCH] Convert vectorof/vector-immutableof to the new regime.

Also add old-style vectorof to mzlib/contract.
---
 collects/mzlib/contract.rkt                   |   2 -
 collects/mzlib/private/contract-mutable.rkt   |  24 ++-
 collects/mzlib/scribblings/contract.scrbl     |   8 +-
 collects/racket/contract/private/vector.rkt   | 187 +++++++++++++-----
 collects/tests/racket/contract-test.rktl      |  12 +-
 .../typed-scheme/private/type-contract.rkt    |   4 +-
 6 files changed, 184 insertions(+), 53 deletions(-)

diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt
index 68296b6b36..1ced3d7025 100644
--- a/collects/mzlib/contract.rkt
+++ b/collects/mzlib/contract.rkt
@@ -37,7 +37,6 @@
 ;;
 
 (require racket/contract/private/base
-         racket/contract/private/vector
          racket/contract/private/misc
          racket/contract/private/provide
          racket/contract/private/guts
@@ -52,7 +51,6 @@
              contract-struct)
  
  (all-from-out racket/contract/private/base)
- (all-from-out racket/contract/private/vector)
  (all-from-out racket/contract/private/provide)
  (except-out (all-from-out racket/contract/private/misc)
              check-between/c
diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt
index 69f4617740..0e09536589 100644
--- a/collects/mzlib/private/contract-mutable.rkt
+++ b/collects/mzlib/private/contract-mutable.rkt
@@ -1,10 +1,13 @@
 #lang racket/base
 
 (require (only-in racket/contract/private/box box-immutable/c)
+         (only-in racket/contract/private/vector
+                  vector/c vector-immutableof vector-immutable/c)
          racket/contract/private/blame
          racket/contract/private/guts)
 
-(provide box/c box-immutable/c)
+(provide box/c box-immutable/c
+         vector/c vectorof vector-immutableof vector-immutable/c)
 
 (define/subexpression-pos-prop (box/c ctc)
   (let ([ctc (coerce-flat-contract 'box/c ctc)])
@@ -22,3 +25,22 @@
              (raise-blame-error blame val "not a box"))
            (proj (unbox val))
            val))))))
+
+(define/subexpression-pos-prop (vectorof ctc)
+  (let ([ctc (coerce-flat-contract 'vectorof ctc)])
+    (make-flat-contract
+     #:name (build-compound-type-name 'vectorof ctc)
+     #:first-order
+     (λ (val)
+       (and (vector? val)
+            (for/and ([v (in-vector val)])
+              (contract-first-order-passes? ctc v))))
+     #:projection
+     (λ (blame)
+       (λ (val)
+         (let ([proj ((contract-projection ctc) blame)])
+           (unless (vector? val)
+             (raise-blame-error blame val "not a vector"))
+           (for ([v (in-vector val)])
+             (proj v))
+           val))))))
diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl
index 77dbdd0238..fe2db58543 100644
--- a/collects/mzlib/scribblings/contract.scrbl
+++ b/collects/mzlib/scribblings/contract.scrbl
@@ -86,8 +86,7 @@ from @schememodname[scheme/contract]:
  syntax/c
  vector-immutable/c
  vector-immutableof
- vector/c
- vectorof]
+ vector/c]
 
 It also provides the old version of the following forms:
 
@@ -113,3 +112,8 @@ that definition.}
 
 Returns a flat contract that recognizes boxes. The content of the box
 must match @racket[c].}
+
+@defproc[(vectorof [c flat-contract?]) flat-contract?]{
+
+Accepts a flat contract and returns a flat contract
+that checks for vectors whose elements match the original contract.}
diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt
index 1adbb694f2..62dec65c8f 100644
--- a/collects/racket/contract/private/vector.rkt
+++ b/collects/racket/contract/private/vector.rkt
@@ -3,55 +3,152 @@
 (require (for-syntax racket/base)
          "guts.ss")
 
-(provide vector/c vectorof vector-immutable/c vector-immutableof)
+(provide vector/c (rename-out [wrap-vectorof vectorof])
+         vector-immutable/c vector-immutableof)
 
-(define-syntax (*-immutableof stx)
+(define-struct vectorof (elem immutable))
+
+(define (vectorof-name c)
+  (let ([immutable (vectorof-immutable c)])
+    (apply build-compound-type-name 'vectorof 
+           (contract-name (vectorof-elem c))
+           (append
+            (if (and (flat-vectorof? c)
+                     (not (eq? immutable #t)))
+                (list '#:flat? #t)
+                null)
+            (if (not (eq? immutable 'dont-care))
+                (list '#:immutable immutable)
+                null)))))
+
+(define (vectorof-first-order c) 
+  (let ([elem-ctc (vectorof-elem c)]
+        [immutable (vectorof-immutable c)]
+        [flat? (flat-vectorof? c)])
+    (λ (val #:blame [blame #f])
+      (let/ec return
+        (define (fail . args)
+          (if blame
+              (apply raise-blame-error blame val args)
+              (return #f)))
+        (unless (vector? val)
+          (fail "expected a vector, got ~a" val))
+        (cond
+          [(eq? immutable #t)
+           (unless (immutable? val)
+             (fail "expected an immutable vector, got ~a" val))]
+          [(eq? immutable #f)
+           (when (immutable? val)
+             (fail "expected an mutable vector, got ~a" val))]
+          [else (void)])
+        (when (or flat? (and (immutable? val) (not blame)))
+          (if blame
+              (let ([elem-proj ((contract-projection elem-ctc) blame)])
+                (for ([e (in-vector val)])
+                  (elem-proj e)))
+              (for ([e (in-vector val)])
+                (unless (contract-first-order-passes? elem-ctc e)
+                  (fail)))))
+        #t))))
+
+(define-struct (flat-vectorof vectorof) ()
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name vectorof-name
+   #:first-order vectorof-first-order
+   #:projection 
+   (λ (ctc) 
+     (λ (blame) 
+       (λ (val)
+         ((vectorof-first-order ctc) val #:blame blame)
+         val)))))
+
+(define (vectorof-ho-projection vector-wrapper)
+  (λ (ctc)
+     (let ([elem-ctc (vectorof-elem ctc)]
+           [immutable (vectorof-immutable ctc)])
+       (λ (blame)
+         (let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
+               [elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
+           (λ (val)
+             ((vectorof-first-order ctc) val #:blame blame)
+             (if (immutable? val)
+                 (apply vector-immutable
+                        (for/list ([e (in-vector val)])
+                          (elem-pos-proj e)))
+                 (vector-wrapper
+                  val
+                  (λ (vec i val)
+                    (elem-pos-proj val))
+                  (λ (vec i val)
+                    (elem-neg-proj val))))))))))
+
+(define-struct (chaperone-vectorof vectorof) ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:name vectorof-name
+   #:first-order vectorof-first-order
+   #:projection (vectorof-ho-projection chaperone-vector)))
+
+(define-struct (proxy-vectorof vectorof) ()
+  #:property prop:contract
+  (build-contract-property
+   #:name vectorof-name
+   #:first-order vectorof-first-order
+   #:projection (vectorof-ho-projection proxy-vector)))
+
+(define-syntax (wrap-vectorof stx)
   (syntax-case stx ()
-    [(_ predicate? fill testmap type-name name)
-     (identifier? (syntax predicate?))
-     (syntax
-      (let ([fill-name fill])
-        (λ (input)
-          (let ([ctc (coerce-contract 'name input)])
-            (if (flat-contract? ctc)
-                (let ([content-pred? (flat-contract-predicate ctc)])
-                  (build-flat-contract
-                   `(name ,(contract-name ctc))
-                   (lambda (x) (and (predicate? x) (testmap content-pred? x)))))
-                (let ([proj (contract-projection ctc)])
-                  (make-contract
-                   #:name (build-compound-type-name 'name ctc)
-                   #:projection
-                   (λ (blame)
-                     (let ([p-app (proj blame)])
-                       (λ (val)
-                         (unless (predicate? val)
-                           (raise-blame-error
-                            blame
-                            val
-                            "expected <~a>, given: ~e"
-                            'type-name
-                            val))
-                         (fill-name p-app val))))
-                   #:first-order predicate?)))))))]))
+    [x
+     (identifier? #'x)
+     (syntax-property
+      (syntax/loc stx build-vectorof)
+      'racket/contract:contract
+      (vector (gensym 'ctc) (list #'x) null))]
+    [(vecof arg ...)
+     (let ([args (syntax->list #'(arg ...))]
+           [this-one (gensym 'ctc)])
+       (define (convert-args args)
+         (let loop ([args args]
+                    [new-args null])
+           (cond
+             [(null? args) (reverse new-args)]
+             [(keyword? (syntax-e (car args)))
+              (if (null? (cdr args))
+                  (reverse (cons (car args) new-args))
+                  (loop (cddr args)
+                        (list* (cadr args) (car args) new-args)))]
+             [else
+              (append (reverse new-args)
+                      (cons (syntax-property
+                             (car args)
+                             'racket/contract:positive-position
+                             this-one)
+                            (cdr args)))])))
+       (with-syntax ([(new-arg ...) (convert-args args)]
+                     [app (datum->syntax stx '#%app)])
+         (syntax-property
+          (syntax/loc stx
+            (app build-vectorof new-arg ...))
+          'racket/contract:contract
+          (vector this-one (list #'vecof) null))))]))
 
-(define/final-prop (immutable-vector? val) (and (immutable? val) (vector? val)))
+(define (build-vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f])
+  (let ([ctc (if flat?
+                 (coerce-flat-contract 'vectorof c)
+                 (coerce-contract 'vectorof c))])
+    (cond
+      [(or flat?
+           (and (eq? immutable #t)
+                (flat-contract? ctc)))
+       (make-flat-vectorof ctc immutable)]
+      [(chaperone-contract? ctc)
+       (make-chaperone-vectorof ctc immutable)]
+      [else
+       (make-proxy-vectorof ctc immutable)])))
 
-(define vector-immutableof
-  (*-immutableof immutable-vector?
-                 (λ (f v) (apply vector-immutable (map f (vector->list v))))
-                 (λ (f v) (andmap f (vector->list v)))
-                 immutable-vector
-                 vector-immutableof))
-
-(define/subexpression-pos-prop (vectorof p)
-  (let* ([ctc (coerce-flat-contract 'vectorof p)]
-         [pred (flat-contract-predicate ctc)])
-    (build-flat-contract
-     (build-compound-type-name 'vectorof ctc)
-     (λ (v)
-       (and (vector? v)
-            (andmap pred (vector->list v)))))))
+(define/subexpression-pos-prop (vector-immutableof c)
+  (build-vectorof c #:immutable #t))
 
 (define/subexpression-pos-prop (vector/c . args)
   (let* ([ctcs (coerce-flat-contracts 'vector/c args)]
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 4e8ad1fc7b..ec9c9f3761 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -8985,8 +8985,10 @@ so that propagation occurs.
   (test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t))
   (test-flat-contract '(listof any/c) (list #t #f) 3)
   
-  (test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t))
-  (test-flat-contract '(vectorof any/c) (vector #t #f) 3)
+  (test-flat-contract '(vectorof boolean? #:flat? #t) (vector #t #f) (vector #f 3 #t))
+  (test-flat-contract '(vectorof any/c #:flat? #t) (vector #t #f) 3)
+  (test-flat-contract '(vector-immutableof boolean?) (vector-immutable #t #f) (vector-immutable #f 3 #t))
+  (test-flat-contract '(vector-immutableof any/c) (vector-immutable #t #f) 3)
   
   (test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) (vector 1 #f))
   (test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) #f)
@@ -10025,6 +10027,12 @@ so that propagation occurs.
   (test-obligations '(box-immutable/c a)
                     '((racket/contract:contract (box-immutable/c) ())
                       (racket/contract:positive-position a)))
+  (test-obligations '(vectorof a)
+                    '((racket/contract:contract (vectorof) ())
+                      (racket/contract:positive-position a)))
+  (test-obligations '(vector-immutableof a)
+                    '((racket/contract:contract (vector-immutableof) ())
+                      (racket/contract:positive-position a)))
   
   
 ;                                                                
diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt
index 5c4b927889..e8eacaf430 100644
--- a/collects/typed-scheme/private/type-contract.rkt
+++ b/collects/typed-scheme/private/type-contract.rkt
@@ -132,7 +132,9 @@
              #'(or/c . cnts)))]
         [(and t (Function: _)) (t->c/fun t)]
         [(Vector: t)
-         #`(vectorof #,(t->c t #:flat #t))]
+         (if flat?
+             #`(vectorof #,(t->c t #:flat #t) #:flat? #t)
+             #`(vectorof #,(t->c t)))]
         [(Box: t)
          (if flat?
              #`(box/c #,(t->c t #:flat #t) #:flat? #t)