From e6a25f65ca357d89399e2077258ca5bcc0e3f9f0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 19 Sep 2012 15:41:24 -0500
Subject: [PATCH] fix first-order test for struct/dc contracts

closes PR 13090
---
 .../racket/contract/private/struct-dc.rkt     | 38 ++++++++++----
 collects/tests/racket/contract-test.rktl      | 52 ++++++++++++++++++-
 2 files changed, 79 insertions(+), 11 deletions(-)

diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt
index 7c81386094..a852d14985 100644
--- a/collects/racket/contract/private/struct-dc.rkt
+++ b/collects/racket/contract/private/struct-dc.rkt
@@ -128,6 +128,25 @@
                    (list (dep-type subcontract)))
              ...]]))))
 
+(define (struct/dc-flat-first-order ctc)
+  (define struct-pred? (base-struct/dc-pred ctc))
+  (λ (v)
+    (and (struct-pred? v) 
+         (let loop ([subcs (base-struct/dc-subcontracts ctc)]
+                    [args '()])
+           (cond
+             [(null? subcs) #t]
+             [else
+              (define subc (car subcs)) 
+              (define val ((subcontract-ref subc) v))
+              (cond
+                [(indep? subc)
+                 (and ((flat-contract-predicate (indep-ctc subc)) val)
+                      (loop (cdr subcs) (cons val args)))]
+                [else
+                 (and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val)
+                      (loop (cdr subcs) (cons val args)))])])))))
+
 (define (struct/dc-first-order ctc)
   (base-struct/dc-pred ctc))
 
@@ -426,7 +445,7 @@
   (parameterize ([skip-projection-wrapper? #t])
     (build-flat-contract-property
      #:name struct/dc-name
-     #:first-order struct/dc-first-order
+     #:first-order struct/dc-flat-first-order
      #:projection struct/dc-proj
      #:stronger struct/dc-stronger?)))
 
@@ -456,15 +475,14 @@
     (cond
       [(indep? subcontract) (impersonator-contract? (indep-ctc subcontract))]
       [(dep? subcontract) (eq? '#:impersonator (dep-type subcontract))]))
-  ((cond
-     [(and (andmap flat-subcontract? subcontracts)
-           (not (ormap subcontract-mutable-field? subcontracts)))
-      make-flat-struct/dc]
-     [(ormap impersonator-subcontract? subcontracts)
-      make-impersonator-struct/dc]
-     [else
-      make-struct/dc])
-   subcontracts pred struct-name here name-info struct/c?))
+  (cond
+    [(and (andmap flat-subcontract? subcontracts)
+          (not (ormap subcontract-mutable-field? subcontracts)))
+     (make-flat-struct/dc subcontracts pred struct-name here name-info struct/c?)]
+    [(ormap impersonator-subcontract? subcontracts)
+     (make-impersonator-struct/dc subcontracts pred struct-name here name-info struct/c?)]
+    [else
+     (make-struct/dc subcontracts pred struct-name here name-info struct/c?)]))
    
 
 (define-for-syntax (get-struct-info id stx)
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 0dde6a6eb6..9177af5f49 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -9467,7 +9467,15 @@
                      'pos
                      'neg)))
    22)
-
+  
+  (test/spec-passed/result
+   'struct/c16
+   '(let ()
+      (struct doll (contents))
+      (list ((flat-contract-predicate (struct/c doll 'center)) (doll 'center))
+            ((flat-contract-predicate (struct/c doll 'center)) (doll 'not-center-center))))
+   '(#t #f))
+  
 
 ;
 ;
@@ -10227,6 +10235,34 @@
                      'neg)))
    #\a)
 
+  (test/spec-passed/result
+   'struct/dc-pred1
+   '(let ()
+      (struct s (a b))
+      (define p? (flat-contract-predicate (struct/dc s [a number?] [b (a) #:flat (<=/c a)])))
+      (list (p? (s 2 1))
+            (p? (s 1 2))))
+   '(#t #f))
+  
+  (test/spec-passed/result
+   'struct/dc-pred2
+   '(let ()
+      (struct s (a b c))
+      (define p? (flat-contract-predicate (struct/dc s 
+                                                     [a number?]
+                                                     [b boolean?]
+                                                     [c (a b)
+                                                        #:flat
+                                                        (if (and (= a 1) b)
+                                                            any/c
+                                                            none/c)])))
+      
+      (list (p? (s 1 #t 'whatever))
+            (p? (s 11 #f 'whatver))))
+   '(#t #f))
+
+
+  
   (contract-error-test
    'struct/dc-imp-nondep-runtime-error
    #'(let ()
@@ -10366,6 +10402,20 @@
    'recursive-contract9
    '(letrec ([ctc (or/c number? (hash/c (recursive-contract ctc #:chaperone) number?))])
       (make-hash (list (cons (make-hash (list (cons 3 4))) 5)))))
+  
+  (test/pos-blame
+   'recursive-contract10
+   '(let ()
+      (struct doll (contents))
+      (letrec ([doll-ctc (recursive-contract (or/c 'center (struct/c doll doll-ctc)) #:flat)])
+        (contract doll-ctc (doll 3) 'pos 'neg))))
+  
+  (test/pos-blame
+   'recursive-contract11
+   '(let ()
+      (struct doll (contents))
+      (letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))])
+        (contract doll-ctc2 (doll 4) 'pos 'neg))))