From fa854f62fc22a81cbb3aa0efa1997ade18c9e7c3 Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Sun, 19 Dec 2010 11:20:51 +0100
Subject: [PATCH] Add vector signatures, and `vector-of' to the HtDP signature
 syntax.

---
 .../deinprogramm/signature/signature-unit.rkt | 47 +++++++++++++++++++
 collects/lang/private/signature-syntax.rkt    | 14 +++++-
 collects/tests/deinprogramm/signature.rkt     | 32 +++++++++++++
 3 files changed, 91 insertions(+), 2 deletions(-)

diff --git a/collects/deinprogramm/signature/signature-unit.rkt b/collects/deinprogramm/signature/signature-unit.rkt
index a0f027464c..fda7d31700 100644
--- a/collects/deinprogramm/signature/signature-unit.rkt
+++ b/collects/deinprogramm/signature/signature-unit.rkt
@@ -25,6 +25,7 @@
    make-predicate-signature
    make-type-variable-signature
    make-list-signature
+   make-vector-signature
    make-mixed-signature
    make-combined-signature
    make-case-signature
@@ -177,6 +178,52 @@
 	(apply proc arbitraries)
 	#f)))
 
+(define vectors-table (make-weak-hasheq)) ; #### ought to do ephemerons, too
+
+(define (make-vector-signature name arg-signature syntax)
+  (make-signature
+   name
+   (lambda (self obj)
+
+     (define (check old-sigs)
+       (let ((old-sigs (cons arg-signature old-sigs)))
+	 (hash-set! vectors-table obj old-sigs)
+	 (let* ((orig (vector->list obj))
+		(els (map (lambda (x)
+			    (apply-signature arg-signature x))
+			  orig)))
+	   (if (andmap eq? orig els)
+	       obj
+	       (let ((new (list->vector els)))
+		 (hash-set! vectors-table obj new old-sigs)
+		 obj)))))
+
+     (cond
+      ((not (vector? obj))
+       (signature-violation obj self #f #f)
+       obj)
+      ((hash-ref vectors-table obj #f)
+       => (lambda (old-sigs)
+	    (if (ormap (lambda (old-sig)
+			 (signature<=? old-sig arg-signature))
+		       old-sigs)
+		obj
+		(check old-sigs))))
+      (else
+       (check '()))))
+   syntax
+   #:arbitrary-promise
+   (delay
+     (lift->arbitrary arbitrary-vector arg-signature))
+   #:info-promise
+   (delay (make-vector-info arg-signature))
+   #:=?-proc
+   (lambda (this-info other-info)
+     (and (vector-info? other-info)
+	  (signature=? arg-signature (vector-info-arg-signature other-info))))))
+
+(define-struct vector-info (arg-signature) #:transparent)
+
 (define (make-mixed-signature name alternative-signatures syntax)
   (letrec ((alternative-signatures-promise 
 	    (delay
diff --git a/collects/lang/private/signature-syntax.rkt b/collects/lang/private/signature-syntax.rkt
index 6ec3ac1d95..160a9fbe66 100644
--- a/collects/lang/private/signature-syntax.rkt
+++ b/collects/lang/private/signature-syntax.rkt
@@ -3,7 +3,7 @@
 (provide :
 	 signature signature/arbitrary
 	 define/signature define-values/signature
-	 -> mixed one-of predicate combined property list-of)
+	 -> mixed one-of predicate combined property list-of vector-of)
 
 (require deinprogramm/signature/signature
 	 deinprogramm/signature/signature-english
@@ -20,7 +20,7 @@
 
 (define-for-syntax (parse-signature name stx)
   (syntax-case* stx
-		(mixed one-of predicate list-of -> combined property reference at signature)
+		(mixed one-of predicate list-of vector-of -> combined property reference at signature)
 		module-or-top-identifier=?
     ((mixed ?signature ...)
      (with-syntax ((?stx (phase-lift stx))
@@ -63,6 +63,15 @@
      (raise-syntax-error #f
 			 "list-of signature accepts only a single operand"
 			 (syntax ?signature1)))
+    ((vector-of ?signature)
+     (with-syntax ((?stx (phase-lift stx))
+		   (?name name)
+		   (?signature-expr (parse-signature #f #'?signature)))
+       #'(make-vector-signature '?name ?signature-expr ?stx)))
+    ((vector-of ?signature1 ?rest ...)
+     (raise-syntax-error #f
+			 "vector-of signature accepts only a single operand"
+			 (syntax ?signature1)))
     ((?arg-signature ... -> ?return-signature)
      (with-syntax ((?stx (phase-lift stx))
 		   (?name name)
@@ -249,3 +258,4 @@
 (define-syntax combined within-signature-syntax-transformer)
 (define-syntax property within-signature-syntax-transformer)
 (define-syntax list-of within-signature-syntax-transformer)
+(define-syntax vector-of within-signature-syntax-transformer)
diff --git a/collects/tests/deinprogramm/signature.rkt b/collects/tests/deinprogramm/signature.rkt
index a2b6df2eb5..54e47a2762 100644
--- a/collects/tests/deinprogramm/signature.rkt
+++ b/collects/tests/deinprogramm/signature.rkt
@@ -86,6 +86,38 @@
       (check-equal? (say-no (proc no2)) 'no))
     )
  
+   (test-case
+    "vector"
+    (define integer-vector (make-vector-signature 'integer-list integer #f))
+    (check-equal? (say-no (apply-signature integer-vector '#(1 2 3)))
+		  '#(1 2 3))
+    (check-equal? (say-no (apply-signature integer-vector '#f))
+		  'no)
+    (check-eq? (failed-signature (apply-signature integer-vector '#(1 #f 3)))
+	       integer))
+
+   (test-case
+    "vector/cached"
+    (let ((count 0))
+      (define counting-integer
+	(make-predicate-signature 'counting-integer 
+				  (lambda (obj)
+				    (set! count (+ 1 count))
+				    (integer? obj))
+				  'integer-marker))
+
+      (define integer-vector (make-vector-signature 'integer-list counting-integer #f))
+
+      (define v1 '#(1 2 3))
+
+      (check-eq? (say-no (apply-signature integer-vector v1))
+		 v1)
+      (check-equal? count 3)
+      (check-eq? (say-no (apply-signature integer-vector v1))
+		 v1)
+      (check-equal? count 3)))
+
+
    (test-case
     "mixed"
     (define int-or-bool (make-mixed-signature 'int-or-bool