From 10eb818f953a4160b7f3c91193739f1451bf192c Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 7 Dec 2010 03:15:16 -0500
Subject: [PATCH] Conversion of struct/c to chaperones when appropriate.

---
 collects/mzlib/contract.rkt                   |   7 ++
 collects/mzlib/private/contract-struct.rkt    |  75 +++++++++++++
 collects/mzlib/scribblings/contract.scrbl     |   7 +-
 collects/racket/contract/base.rkt             |   2 +
 collects/racket/contract/private/misc.rkt     |  70 ------------
 collects/racket/contract/private/struct.rkt   | 105 ++++++++++++++++++
 .../scribblings/reference/contracts.scrbl     |  12 +-
 collects/tests/racket/contract-test.rktl      |  77 ++++++++++++-
 8 files changed, 279 insertions(+), 76 deletions(-)
 create mode 100644 collects/mzlib/private/contract-struct.rkt
 create mode 100644 collects/racket/contract/private/struct.rkt

diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt
index 1ced3d7025..01f022f5e9 100644
--- a/collects/mzlib/contract.rkt
+++ b/collects/mzlib/contract.rkt
@@ -30,6 +30,13 @@
 (require "private/contract-mutable.rkt")
 (provide (all-from-out "private/contract-mutable.rkt"))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; old-style flat struct contracts
+;;
+(require "private/contract-struct.rkt")
+(provide (all-from-out "private/contract-struct.rkt"))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; provide everything from the racket/ implementation
diff --git a/collects/mzlib/private/contract-struct.rkt b/collects/mzlib/private/contract-struct.rkt
new file mode 100644
index 0000000000..733a148aba
--- /dev/null
+++ b/collects/mzlib/private/contract-struct.rkt
@@ -0,0 +1,75 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     racket/contract/private/helpers
+                     racket/struct-info)
+         racket/contract/private/guts)
+
+(provide struct/c)
+
+  #|
+    as with copy-struct in struct.rkt, this first begin0
+    expansion "declares" that struct/c is an expression.
+    It prevents further expansion until the internal definition
+    context is sorted out.
+   |#
+(define-syntax (struct/c stx)
+  (syntax-case stx ()
+    [(_ . args) 
+     (with-syntax ([x (syntax/loc stx (do-struct/c . args))])
+       (syntax/loc stx (begin0 x)))]))
+
+(define-syntax (do-struct/c stx)
+  (syntax-case stx ()
+    [(_ struct-name args ...)
+     (and (identifier? (syntax struct-name))
+          (struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
+     (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(field-numbers ...)
+                    (let loop ([i 0]
+                               [l (syntax->list (syntax (args ...)))])
+                      (cond
+                        [(null? l) '()]
+                        [else (cons i (loop (+ i 1) (cdr l)))]))]
+                   [(type-desc-id 
+                     constructor-id 
+                     predicate-id 
+                     (rev-selector-id ...)
+                     (mutator-id ...)
+                     super-id)
+                    (lookup-struct-info (syntax struct-name) stx)])
+       (unless (= (length (syntax->list (syntax (rev-selector-id ...))))
+                  (length (syntax->list (syntax (args ...)))))
+         (raise-syntax-error 'struct/c 
+                             (format "expected ~a contracts because struct ~a has ~a fields"
+                                     (length (syntax->list (syntax (rev-selector-id ...))))
+                                     (syntax-e #'struct-name)
+                                     (length (syntax->list (syntax (rev-selector-id ...)))))
+                             stx))
+       (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
+         (syntax
+          (let ([ctc-x (coerce-contract 'struct/c args)] ...)
+            
+            (unless predicate-id
+              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
+            (unless (and selector-id ...)
+              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
+            
+            (unless (flat-contract? ctc-x)
+              (error 'struct/c "expected flat contracts as arguments, got ~e" args))
+            ...
+            
+            (let ([ctc-pred-x (flat-contract-predicate ctc-x)] 
+                  ...
+                  [ctc-name-x (contract-name ctc-x)]
+                  ...)
+              (build-flat-contract
+               (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
+               (λ (val)
+                 (and (predicate-id val)
+                      (ctc-pred-x (selector-id val)) ...))))))))]
+    [(_ struct-name anything ...)
+     (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
\ No newline at end of file
diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl
index 6080d86a40..32f8d844f8 100644
--- a/collects/mzlib/scribblings/contract.scrbl
+++ b/collects/mzlib/scribblings/contract.scrbl
@@ -81,7 +81,6 @@ from @schememodname[scheme/contract]:
  real-in
  recursive-contract
  string/len
- struct/c
  symbols
  syntax/c
  vector-immutable/c
@@ -124,3 +123,9 @@ flat contract that recognizes vectors. The number of elements in the
 vector must match the number of arguments supplied to
 @racket[vector/c], and each element of the vector must match the
 corresponding flat contract.}
+
+@defform[(struct/c struct-id flat-contract-expr ...)]{
+
+Produces a flat contract that recognizes instances of the structure
+type named by @racket[struct-id], and whose field values match the
+flat contracts produced by the @racket[flat-contract-expr]s.}
diff --git a/collects/racket/contract/base.rkt b/collects/racket/contract/base.rkt
index 6f06480b44..d63671714e 100644
--- a/collects/racket/contract/base.rkt
+++ b/collects/racket/contract/base.rkt
@@ -9,6 +9,7 @@
          "private/box.rkt"
          "private/hash.rkt"
          "private/vector.rkt"
+         "private/struct.rkt"
          "private/misc.rkt"
          "private/provide.rkt"
          "private/guts.rkt"
@@ -31,6 +32,7 @@
  (all-from-out "private/box.rkt")
  (all-from-out "private/hash.rkt")
  (all-from-out "private/vector.rkt")
+ (all-from-out "private/struct.rkt")
  (except-out (all-from-out "private/misc.rkt")
              check-between/c
              check-unary-between/c)
diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt
index d79f083879..ce02d65473 100644
--- a/collects/racket/contract/private/misc.rkt
+++ b/collects/racket/contract/private/misc.rkt
@@ -1,7 +1,6 @@
 #lang racket/base
 
 (require (for-syntax racket/base
-                     racket/struct-info
                      "helpers.rkt"
                      "opt-guts.rkt")
          racket/promise
@@ -22,7 +21,6 @@
          symbols one-of/c
          listof non-empty-listof cons/c list/c
          promise/c
-         struct/c
          syntax/c
          
          check-between/c
@@ -1022,74 +1020,6 @@
              (delay (p-app (force val))))))
        #:first-order promise?))))
 
-#|
-   as with copy-struct in struct.rkt, this first begin0
-   expansion "declares" that struct/c is an expression.
-   It prevents further expansion until the internal definition
-   context is sorted out.
-  |#
-(define-syntax (struct/c stx)
-  (syntax-case stx ()
-    [(_ . args) 
-     (with-syntax ([x (syntax/loc stx (do-struct/c . args))])
-       (syntax/loc stx (begin0 x)))]))
-
-(define-syntax (do-struct/c stx)
-  (syntax-case stx ()
-    [(_ struct-name args ...)
-     (and (identifier? (syntax struct-name))
-          (struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
-     (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(field-numbers ...)
-                    (let loop ([i 0]
-                               [l (syntax->list (syntax (args ...)))])
-                      (cond
-                        [(null? l) '()]
-                        [else (cons i (loop (+ i 1) (cdr l)))]))]
-                   [(type-desc-id 
-                     constructor-id 
-                     predicate-id 
-                     (rev-selector-id ...)
-                     (mutator-id ...)
-                     super-id)
-                    (lookup-struct-info (syntax struct-name) stx)])
-       (unless (= (length (syntax->list (syntax (rev-selector-id ...))))
-                  (length (syntax->list (syntax (args ...)))))
-         (raise-syntax-error 'struct/c 
-                             (format "expected ~a contracts because struct ~a has ~a fields"
-                                     (length (syntax->list (syntax (rev-selector-id ...))))
-                                     (syntax-e #'struct-name)
-                                     (length (syntax->list (syntax (rev-selector-id ...)))))
-                             stx))
-       (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
-         (syntax
-          (let ([ctc-x (coerce-contract 'struct/c args)] ...)
-            
-            (unless predicate-id
-              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
-            (unless (and selector-id ...)
-              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
-            
-            (unless (flat-contract? ctc-x)
-              (error 'struct/c "expected flat contracts as arguments, got ~e" args))
-            ...
-            
-            (let ([ctc-pred-x (flat-contract-predicate ctc-x)] 
-                  ...
-                  [ctc-name-x (contract-name ctc-x)]
-                  ...)
-              (build-flat-contract
-               (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
-               (λ (val)
-                 (and (predicate-id val)
-                      (ctc-pred-x (selector-id val)) ...))))))))]
-    [(_ struct-name anything ...)
-     (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
-
-
 (define/subexpression-pos-prop (parameter/c x)
   (make-parameter/c (coerce-contract 'parameter/c x)))
 
diff --git a/collects/racket/contract/private/struct.rkt b/collects/racket/contract/private/struct.rkt
new file mode 100644
index 0000000000..6f1c91e1a6
--- /dev/null
+++ b/collects/racket/contract/private/struct.rkt
@@ -0,0 +1,105 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     racket/struct-info
+                     "helpers.rkt")
+         "guts.rkt")
+
+(provide struct/c)
+
+#|
+  as with copy-struct in struct.rkt, this first begin0
+  expansion "declares" that struct/c is an expression.
+  It prevents further expansion until the internal definition
+  context is sorted out.
+|#
+(define-syntax (struct/c stx)
+  (syntax-case stx ()
+    [(_ . args) 
+     (with-syntax ([x (syntax/loc stx (do-struct/c . args))])
+       (syntax/loc stx (begin0 x)))]))
+
+(define-syntax (do-struct/c stx)
+  (syntax-case stx ()
+    [(_ struct-name args ...)
+     (and (identifier? (syntax struct-name))
+          (struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
+     (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-proj-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-pos-proj-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-neg-proj-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
+                   [(field-numbers ...)
+                    (let loop ([i 0]
+                               [l (syntax->list (syntax (args ...)))])
+                      (cond
+                        [(null? l) '()]
+                        [else (cons i (loop (+ i 1) (cdr l)))]))]
+                   [(type-desc-id 
+                     constructor-id 
+                     predicate-id 
+                     (rev-selector-id ...)
+                     (rev-mutator-id ...)
+                     super-id)
+                    (lookup-struct-info (syntax struct-name) stx)])
+       (unless (= (length (syntax->list (syntax (rev-selector-id ...))))
+                  (length (syntax->list (syntax (args ...)))))
+         (raise-syntax-error 'struct/c 
+                             (format "expected ~a contracts because struct ~a has ~a fields"
+                                     (length (syntax->list (syntax (rev-selector-id ...))))
+                                     (syntax-e #'struct-name)
+                                     (length (syntax->list (syntax (rev-selector-id ...)))))
+                             stx))
+       (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]
+                     [(mutator-id ...)  (reverse (syntax->list (syntax (rev-mutator-id ...))))])
+         (syntax
+          (let ([ctc-x (coerce-contract 'struct/c args)] ...)
+            
+            (unless predicate-id
+              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
+            (unless (and selector-id ...)
+              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
+            (unless (chaperone-contract? ctc-x)
+              (error 'struct/c "expected chaperone contracts as arguments, got ~e" args))
+            ...
+            
+            (let* ([ctc-pred-x (contract-first-order ctc-x)] 
+                   ...
+                   [ctc-name-x (contract-name ctc-x)]
+                   ...
+                   ;; To have a flat contract result, all of the contracted fields must be immutable
+                   ;; and all the contracts must be flat.
+                   [flat? (and (andmap not (list mutator-id ...))
+                               (for/and ([c (in-list (list ctc-x ...))])
+                                 (flat-contract? c)))]
+                   [fo-check (λ (val)
+                               (and (predicate-id val)
+                                    (ctc-pred-x (selector-id val)) ...))])
+              (if flat?
+                  (build-flat-contract
+                   (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
+                   fo-check)
+                  (make-chaperone-contract
+                   #:name (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
+                   #:first-order fo-check
+                   #:projection
+                   (let ([ctc-proj-x (contract-projection ctc-x)] ...)
+                     (λ (blame)
+                       (let* ([swapped-blame (blame-swap blame)]
+                              [ctc-pos-proj-x (ctc-proj-x blame)] ...
+                              [ctc-neg-proj-x (ctc-proj-x swapped-blame)] ...)
+                         (λ (val)
+                           (unless (predicate-id val)
+                             (raise-blame-error blame val "expected a <~a>, got ~v" struct-name val))
+                           ;; Do first order checks on values in case the struct doesn't adhere to them
+                           ;; at wrapping time
+                           (ctc-pos-proj-x (selector-id val)) ...
+                           (apply chaperone-struct val
+                                  (append (list* selector-id (λ (s v) (ctc-pos-proj-x v))
+                                                 (if mutator-id
+                                                     (list mutator-id (λ (s v) (ctc-neg-proj-x v)))
+                                                     null)) ...)))))))))))))]
+    [(_ struct-name anything ...)
+     (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 34b893bade..6ed0c772b8 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -1,3 +1,4 @@
+
 #lang scribble/doc
 @(require "mz.rkt")
 @(require (for-label syntax/modcollapse))
@@ -23,6 +24,7 @@ constraints.
                                          racket/contract/private/box
                                          racket/contract/private/hash
                                          racket/contract/private/vector
+                                         racket/contract/private/struct
                                          racket/contract/private/misc
                                          racket/contract/private/provide)]
 
@@ -343,11 +345,15 @@ Produces a flat contract that recognizes syntax objects whose
 @racket[syntax-e] content matches @racket[c].}
 
 
-@defform[(struct/c struct-id flat-contract-expr ...)]{
+@defform[(struct/c struct-id chaperone-contract-expr ...)]{
 
-Produces a flat contract that recognizes instances of the structure
+Produces a contract that recognizes instances of the structure
 type named by @racket[struct-id], and whose field values match the
-@tech{flat contracts} produced by the @racket[flat-contract-expr]s.}
+chaperone contracts produced by the @racket[chaperone-contract-expr]s.
+
+If the fields are immutable and the @racket[chaperone-contract-expr]s evaluate
+to flat contracts, a flat contract is produced. Otherwise, a chaperone
+contract is produced.}
 
 
 @defproc[(parameter/c [c contract?]) contract?]{
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index d976f5208e..4d887afe94 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -7946,6 +7946,67 @@
                 (make-s 1 (make-s 2 3))
                 'pos
                 'neg)))
+  
+  (test/spec-passed
+   'struct/c6
+   '(let ()
+      (define-struct s (f))
+      (let ([v (contract (struct/c s (-> number? number?))
+                         (make-s values)
+                         'pos
+                         'neg)])
+        ((s-f v) 3))))
+
+  (test/neg-blame
+   'struct/c7
+   '(let ()
+      (define-struct s (f))
+      (let ([v (contract (struct/c s (-> number? number?))
+                         (make-s values)
+                         'pos
+                         'neg)])
+        ((s-f v) #f))))
+
+  (test/pos-blame
+   'struct/c8
+   '(let ()
+      (define-struct s (f))
+      (let ([v (contract (struct/c s (-> number? number?))
+                         (make-s (λ (v) #f))
+                         'pos
+                         'neg)])
+        ((s-f v) 3))))
+  
+  (test/spec-passed
+   'struct/c9
+   '(let ()
+      (define-struct s (a b) #:mutable)
+      (let ([v (contract (struct/c s integer? boolean?)
+                         (make-s 3 #t)
+                         'pos
+                         'neg)])
+        (set-s-a! v 4)
+        (set-s-b! v #t))))
+
+  (test/neg-blame
+   'struct/c10
+   '(let ()
+      (define-struct s (a b) #:mutable)
+      (let ([v (contract (struct/c s integer? boolean?)
+                         (make-s 3 #t)
+                         'pos
+                         'neg)])
+        (set-s-a! v #f))))
+
+  (test/neg-blame
+   'struct/c11
+   '(let ()
+      (define-struct s (a [b #:mutable]))
+      (let ([v (contract (struct/c s integer? boolean?)
+                         (make-s 3 #t)
+                         'pos
+                         'neg)])
+        (set-s-b! v 5))))
 
   
 ;                                                                              
@@ -8917,8 +8978,20 @@ so that propagation occurs.
   (ctest #t flat-contract? (and/c (flat-contract number?)
 				 (flat-contract integer?)))
   (ctest #t flat-contract? (let ()
-                            (define-struct s (a b))
-                            (struct/c s any/c any/c)))
+                             (define-struct s (a b))
+                             (struct/c s any/c any/c)))
+  (ctest #t chaperone-contract? (let ()
+                                  (define-struct s (a b) #:mutable)
+                                  (struct/c s any/c any/c)))
+  (ctest #t chaperone-contract? (let ()
+                                  (define-struct s ([a #:mutable] b))
+                                  (struct/c s any/c any/c)))
+  (ctest #t chaperone-contract? (let ()
+                                  (define-struct s (a [b #:mutable]))
+                                  (struct/c s any/c any/c)))
+  (ctest #t chaperone-contract? (let ()
+                                  (define-struct s (f))
+                                  (struct/c s (-> number? any))))
   
   ;; Hash contracts with flat domain/range contracts
   (ctest #t contract?           (hash/c any/c any/c #:immutable #f))