fix cons/c for combinators that insist on projections for subcontracts

rfindler · rfindler · commit 01fb28fa87c5 · 2014-05-17T16:06:14.000-05:00
(instead of working with val-first projections)
diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/box.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/box.rkt
@@ -5,4 +5,25 @@
    '(let ([v (chaperone-box (box-immutable 1)
                             (λ (box v) v)
                             (λ (box v) v))])
-      (contract (box/c any/c) v 'pos 'neg))))
+      (contract (box/c any/c) v 'pos 'neg)))
+  
+  (test/pos-blame
+   'box/c1
+   '(contract (box/c any/c) #f 'pos 'neg))
+  
+  (test/pos-blame
+   'box/c2
+   '(unbox (contract (box/c integer?) (box #f) 'pos 'neg)))
+  
+  (test/pos-blame
+   'box/c3
+   '(contract (box/c integer?) (box-immutable #f) 'pos 'neg))
+  
+  (test/neg-blame
+   'box/c-with-cons/c-inside
+   '(let ([f
+           (contract (box/c (cons/c (-> boolean? boolean?) '()))
+                     (box (list values))
+                     'pos 
+                     'neg)])
+      ((car (unbox f)) 3))))
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
@@ -534,7 +534,7 @@
 (define (blame-add-cdr-context blame) (blame-add-context blame "the cdr of"))
 
 
-(define ((val-first-ho-check combine) ctc)
+(define ((cons/c-val-first-ho-check combine) ctc)
   (define ctc-car (the-cons/c-hd-ctc ctc))
   (define ctc-cdr (the-cons/c-tl-ctc ctc))
   (define car-val-first-proj (get/build-val-first-projection ctc-car))
@@ -550,6 +550,19 @@
                  ((car-p (car v)) neg-party)
                  ((cdr-p (cdr v)) neg-party))))))
 
+(define ((cons/c-ho-check combine) ctc)
+  (define ctc-car (the-cons/c-hd-ctc ctc))
+  (define ctc-cdr (the-cons/c-tl-ctc ctc))
+  (define car-proj (contract-projection ctc-car))
+  (define cdr-proj (contract-projection ctc-cdr))
+  (λ (blame)
+    (let ([car-p (car-proj (blame-add-car-context blame))]
+          [cdr-p (cdr-proj (blame-add-cdr-context blame))])
+      (λ (v)
+        (unless (pair? v)
+          (raise-not-cons-blame-error blame v))
+        (combine v (car-p (car v)) (cdr-p (cdr v)))))))
+
 (define (cons/c-first-order ctc)
   (define ctc-car (the-cons/c-hd-ctc ctc))
   (define ctc-cdr (the-cons/c-tl-ctc ctc))
@@ -585,7 +598,8 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
-   #:val-first-projection (val-first-ho-check (λ (v a d) v))
+   #:val-first-projection (cons/c-val-first-ho-check (λ (v a d) v))
+   #:projection (cons/c-ho-check (λ (v a d) v))
    #:name cons/c-name
    #:first-order cons/c-first-order
    #:stronger cons/c-stronger?
@@ -595,7 +609,8 @@
   #:property prop:chaperone-contract
   (parameterize ([skip-projection-wrapper? #t])
     (build-chaperone-contract-property
-     #:val-first-projection (val-first-ho-check (λ (v a d) (cons a d)))
+     #:val-first-projection (cons/c-val-first-ho-check (λ (v a d) (cons a d)))
+     #:projection (cons/c-ho-check (λ (v a d) (cons a d)))
      #:name cons/c-name
      #:first-order cons/c-first-order
      #:stronger cons/c-stronger?
@@ -604,7 +619,8 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
-   #:val-first-projection (val-first-ho-check (λ (v a d) (cons a d)))
+   #:val-first-projection (cons/c-val-first-ho-check (λ (v a d) (cons a d)))
+   #:projection (cons/c-ho-check (λ (v a d) (cons a d)))
    #:name cons/c-name
    #:first-order cons/c-first-order
    #:stronger cons/c-stronger?
