clean up interaction between strict set/c contracts and mutable sets

milapsheth · Dec 30, 2015 · 46ace31 · 46ace31
1 parent 757adac
commit 46ace31
Show file tree

Hide file tree

Showing 2 changed files with 65 additions and 45 deletions.
diff --git a/pkgs/racket-test/tests/racket/contract/set.rkt b/pkgs/racket-test/tests/racket/contract/set.rkt
@@ -166,12 +166,20 @@
                 (binary-set 5)
                 'pos 'neg)))
 
-  (test/spec-passed
+  (test/spec-passed/result
    'set/c21
    '(let* ([c (set/c (-> integer? integer?))]
            [s (contract c (set (λ (x) x)) 'pos 'neg)])
       (and (has-contract? s)
-           (equal? (value-contract s) c))))
+           (equal? (value-contract s) c)))
+   #t)
+
+  (test/spec-passed/result
+   'set/c2b
+   '(let* ([c (set/c (-> integer? integer?))]
+           [s (contract c (set (λ (x) x)) 'pos 'neg)])
+      (has-blame? s))
+   #t)
 
   (test/spec-passed
    'set/c22
@@ -207,14 +215,34 @@
 
   (test/neg-blame
    'set/c28
-   '(let ([s (contract (set/c integer? #:lazy? #t)
-                       (set #f) 'pos 'neg)])
+   '(let ([s (contract (set/c integer? #:lazy? #t #:kind 'dont-care)
+                       (mutable-set #f) 'pos 'neg)])
       (set-add! s "x")))
 
   (test/neg-blame
    'set/c29
-   '(let ([s (contract (set/c integer? #:lazy? #f)
-                       (set 0) 'pos 'neg)])
+   '(let ([s (contract (set/c integer? #:lazy? #f #:kind 'mutable)
+                       (mutable-set 0) 'pos 'neg)])
       (set-add! s "x")))
+
+  (test/spec-passed
+   'set/c30
+   '(let ()
+      (define-custom-set-types set2 equal?)
+      (set-add
+       (contract (set/c (-> integer? integer?))
+                 (make-immutable-set2)
+                 'pos 'neg)
+       add1)))
+
+  (test/spec-passed
+   'set/c30
+   '(let ()
+      (define-custom-set-types set2 equal?)
+      (set-add
+       (contract (set/c (-> integer? integer?))
+                 (make-immutable-set2)
+                 'pos 'neg)
+       add1)))
 
   )
diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt
@@ -184,50 +184,42 @@
   (λ (blame)
     (define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f)))
     (define late-neg-neg-proj (late-neg-ele-proj (blame-add-element-context blame #t)))
-    (define set/c-lazy-late-neg-proj
-      (λ (val neg-party)
+    (cond
+      [lazy?
+       (λ (val neg-party)
         (set-contract-check cmp kind blame neg-party val)
         (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
-        (cond
-          [(set? val)
-           (chaperone-hash-set
-            val
-            pos-interpose
-            (λ (val ele) ele)
-            pos-interpose
-            impersonator-prop:contracted
-            ctc)]
-          [else
-           (chaperone-hash-set
-            val
-            pos-interpose
-            (λ (val ele) (late-neg-neg-proj ele neg-party))
-            pos-interpose
-            impersonator-prop:contracted
-            ctc)])))
-    (cond
-      [lazy? set/c-lazy-late-neg-proj]
+         (chaperone-hash-set
+          val
+          pos-interpose
+          (λ (val ele) (late-neg-neg-proj ele neg-party))
+          pos-interpose
+          impersonator-prop:contracted ctc
+          impersonator-prop:blame (cons blame neg-party)))]
       [else
        (λ (val neg-party)
          (set-contract-check cmp kind blame neg-party val)
-         (define w/chaperone
-           (cond
-             [(set? val) val]
-             [else
-              (chaperone-hash-set
-               val
-               (λ (val ele) ele)
-               (λ (val ele) (late-neg-neg-proj ele neg-party))
-               (λ (val ele) ele))]))
-         (chaperone-hash-set
-          (for/set ([ele (in-set w/chaperone)])
-            (late-neg-pos-proj ele neg-party))
-          (chaperone-hash-set
-           val
-           #f #f #f
-           impersonator-prop:contracted
-           ctc)))])))
-
+         (cond
+           [(set? val)
+            (chaperone-hash-set
+             (for/fold ([s (set-clear val)])
+                       ([e (in-set val)])
+               (set-add s (late-neg-pos-proj e neg-party)))
+             #f #f #f
+             impersonator-prop:contracted ctc
+             impersonator-prop:blame (cons blame neg-party))]
+           [else
+            (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
+            (for ([ele (in-list (set->list val))])
+              (set-remove! val ele)
+              (set-add! val (late-neg-pos-proj ele neg-party)))
+            (chaperone-hash-set
+             val
+             pos-interpose
+             (λ (val ele) (late-neg-neg-proj ele neg-party))
+             pos-interpose
+             impersonator-prop:contracted ctc
+             impersonator-prop:blame (cons blame neg-party))]))])))
 
 (define (generic-set-late-neg-projection ctc chaperone-ctc?)
   (define elem/c (set-contract-elem/c ctc))