improvements to set/c

- use chaperone-hash-set for set/c when the contract allows only hash-sets

- add a #:lazy flag to allow explicit choice of when to use laziness
  (but have a backwards-compatible default that, roughly, eschews laziness
   only when the resulting contract would be flat)

pkgs/racket-doc/scribblings/reference/sets.scrbl

@@ -203,17 +203,20 @@ named by the @racket[sym]s.
                  'dont-care]
                 [#:kind kind 
                  (or/c 'dont-care 'immutable 'mutable 'weak 'mutable-or-weak)
-                 'immutable])
+                 'immutable]
+                [#:lazy? lazy? any/c
+                 (not (and (equal? kind 'immutable)
+                           (flat-contract? elem/c)))])
          contract?]{
 
   Constructs a contract that recognizes sets whose elements match
-  @racket[contract].
+  @racket[elem/c].
 
   If @racket[kind] is @racket['immutable], @racket['mutable], or
   @racket['weak], the resulting contract accepts only @tech{hash sets} that
   are respectively immutable, mutable with strongly-held keys, or mutable with
   weakly-held keys.  If @racket[kind] is @racket['mutable-or-weak], the
-  resulting contract accepts any mutable @racket{hash sets}, regardless of
+  resulting contract accepts any mutable @tech{hash sets}, regardless of
   key-holding strength.
 
   If @racket[cmp] is @racket['equal], @racket['eqv], or @racket['eq], the
@@ -221,12 +224,30 @@ named by the @racket[sym]s.
   using @racket[equal?], @racket[eqv?], or @racket[eq?], respectively.
 
   If @racket[cmp] is @racket['eqv] or @racket['eq], then @racket[elem/c] must
-  be a flat contract.
+  be a @tech{flat contract}.
 
   If @racket[cmp] and @racket[kind] are both @racket['dont-care], then the
   resulting contract will accept any kind of set, not just @tech{hash
   sets}.
 
+ If @racket[lazy?] is not @racket[#f], then the elements of the set are not checked
+ immediately by the contract and only the set itself is checked (according to the
+ @racket[cmp] and @racket[kind] arguments). If @racket[lazy?] is
+ @racket[#f], then the elements are checked immediately by the contract.
+ The @racket[lazy?] argument is ignored when the set contract accepts generic sets
+ (i.e., when @racket[cmp] and @racket[kind] are both @racket['dont-care]); in that
+ case, the value being checked in that case is a @racket[list?], then the contract
+ is not lazy otherwise the contract is lazy.
+ 
+ If @racket[kind] allows mutable sets (i.e., is @racket['dont-care],
+ @racket['mutable], @racket['weak], or
+ @racket['mutable-or-weak]) and @racket[lazy?] is @racket[#f], then the elements
+ are checked both immediately and when they are accessed from the set.
+ 
+ The result contract will be a @tech{flat contract} when @racket[elem/c] is a @tech{flat
+ contract}, @racket[lazy?] is @racket[#f], and @racket[kind] is @racket['immutable].
+ The result will be a @tech{chaperone contract} when @racket[elem/c] is a
+ @tech{chaperone contract}.
 }
 
 @section{Generic Set Interface}

pkgs/racket-test/tests/racket/contract/name.rkt

@@ -393,6 +393,7 @@
   (test-name '(set/c char? #:cmp 'eq) (set/c char? #:cmp 'eq))
   (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv))
   (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal))
+  (test-name '(set/c (-> integer? boolean?)) (set/c (-> integer? boolean?)))
   
   (test-name 'α (let ([α (new-∀/c)]) α))
   (test-name 'α (let ([α (new-∀/c #f)]) α))

pkgs/racket-test/tests/racket/contract/set.rkt

@@ -109,4 +109,112 @@
    '(contract (set/c integer? #:kind 'mutable)
               (mutable-set 0)
               'pos 'neg)
-   (contract-eval '(mutable-set 0))))
+   (contract-eval '(mutable-set 0)))
+
+
+  (test/pos-blame
+   'set/c17
+   '(let ()
+      (struct binary-set [integer]
+        #:transparent
+        #:methods gen:set
+        [(define (set-member? st i)
+           (bitwise-bit-set? (binary-set-integer st) i))
+         (define (set-add st i)
+           (binary-set (bitwise-ior (binary-set-integer st)
+                                    (arithmetic-shift 1 i))))
+         (define (set-remove st i)
+           (binary-set (bitwise-and (binary-set-integer st)
+                                    (bitwise-not (arithmetic-shift 1 i)))))])
+      (contract (set/c integer?)
+                (binary-set 5)
+                'pos 'neg)))
+
+  (test/spec-passed
+   'set/c19
+   '(let ()
+      (struct binary-set [integer]
+        #:transparent
+        #:methods gen:set
+        [(define (set-member? st i)
+           (bitwise-bit-set? (binary-set-integer st) i))
+         (define (set-add st i)
+           (binary-set (bitwise-ior (binary-set-integer st)
+                                    (arithmetic-shift 1 i))))
+         (define (set-remove st i)
+           (binary-set (bitwise-and (binary-set-integer st)
+                                    (bitwise-not (arithmetic-shift 1 i)))))])
+      (contract (set/c integer? #:kind 'dont-care)
+                (binary-set 5)
+                'pos 'neg)))
+
+  (test/spec-passed
+   'set/c20
+   '(let ()
+      (struct binary-set [integer]
+        #:transparent
+        #:methods gen:set
+        [(define (set-member? st i)
+           (bitwise-bit-set? (binary-set-integer st) i))
+         (define (set-add st i)
+           (binary-set (bitwise-ior (binary-set-integer st)
+                                    (arithmetic-shift 1 i))))
+         (define (set-remove st i)
+           (binary-set (bitwise-and (binary-set-integer st)
+                                    (bitwise-not (arithmetic-shift 1 i)))))])
+      (contract (set/c boolean? #:kind 'dont-care #:lazy? #t)
+                (binary-set 5)
+                'pos 'neg)))
+
+  (test/spec-passed
+   '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))))
+
+  (test/spec-passed
+   'set/c22
+   '(contract (set/c (-> integer? integer?) #:lazy? #t)
+              (set #f) 'pos 'neg))
+
+  (test/pos-blame
+   'set/c23
+   '(set-first
+     (contract (set/c (-> integer? integer?) #:lazy? #t)
+               (set #f) 'pos 'neg)))
+
+  (test/pos-blame
+   'set/c24
+   '(contract (set/c (-> integer? integer?) #:lazy? #f)
+              (set #f) 'pos 'neg))
+
+  (test/spec-passed
+   'set/c25
+   '(contract (set/c integer? #:lazy? #t)
+              (set #f) 'pos 'neg))
+
+  (test/pos-blame
+   'set/c26
+   '(set-first
+     (contract (set/c integer? #:lazy? #t)
+               (set #f) 'pos 'neg)))
+
+  (test/pos-blame
+   'set/c27
+   '(contract (set/c integer? #:lazy? #f)
+              (set #f) 'pos 'neg))
+
+  (test/neg-blame
+   'set/c28
+   '(let ([s (contract (set/c integer? #:lazy? #t)
+                       (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)])
+      (set-add! s "x")))
+  
+  )

racket/collects/racket/set.rkt

@@ -12,9 +12,14 @@
          (all-from-out racket/private/set-types)
          set/c)
 
-(define (set/c elem/c
+(define/subexpression-pos-prop/name
+  real-set/c-name (set/c elem/c
                          #:cmp [cmp 'dont-care]
-               #:kind [kind 'immutable])
+                         #:kind [kind 'immutable]
+                         #:lazy? [_lazy?
+                                  (not (and (equal? kind 'immutable)
+                                            (flat-contract? elem/c)))])
+  (define lazy? (and _lazy? #t))
   (define cmp/c
     (case cmp
       [(dont-care) any/c]
@@ -47,14 +52,15 @@
        (raise-argument-error 'set/c "chaperone-contract?" elem/c))])
   (cond
     [(and (eq? kind 'immutable)
+          (not lazy?)
           (flat-contract? elem/c))
-     (flat-set-contract elem/c cmp kind)]
+     (flat-set-contract elem/c cmp kind lazy?)]
     [(chaperone-contract? elem/c)
-     (chaperone-set-contract elem/c cmp kind)]
+     (chaperone-set-contract elem/c cmp kind lazy?)]
     [else
-     (impersonator-set-contract elem/c cmp kind)]))
+     (impersonator-set-contract elem/c cmp kind lazy?)]))
 
-(struct set-contract [elem/c cmp kind])
+(struct set-contract [elem/c cmp kind lazy?])
 
 (define (set-contract-name ctc)
   (define elem/c (set-contract-elem/c ctc))
@@ -66,7 +72,11 @@
                 `[#:cmp (quote ,cmp)])
           ,@(if (eq? kind 'immutable)
                 `[]
-                `[#:kind (quote ,kind)])))
+                `[#:kind (quote ,kind)])
+          ,@(if (equal? (set-contract-lazy? ctc)
+                        (flat-contract? elem/c))
+                '()
+                `(#:lazy? ,(set-contract-lazy? ctc)))))
 
 (define (set-contract-first-order ctc)
   (define cmp (set-contract-cmp ctc))
@@ -116,9 +126,75 @@
 
 (define (set-contract-late-neg-projection chaperone-ctc?)
   (lambda (ctc)
+    (cond
+      [(allows-generic-sets? ctc)
+       (generic-set-late-neg-projection ctc chaperone-ctc?)]
+      [else
+       (hash-set-late-neg-projection ctc chaperone-ctc?)])))
+
+(define (allows-generic-sets? ctc)
+  (and (equal? 'dont-care (set-contract-kind ctc))
+       (equal? 'dont-care (set-contract-cmp ctc))))
+
+(define (hash-set-late-neg-projection ctc chaperone-ctc?)
   (define elem/c (set-contract-elem/c ctc))
   (define cmp (set-contract-cmp ctc))
   (define kind (set-contract-kind ctc))
+  (define late-neg-ele-proj (contract-late-neg-projection elem/c))
+  (define lazy? (set-contract-lazy? ctc))
+  (λ (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)
+        (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]
+      [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)))])))
+            
+
+(define (generic-set-late-neg-projection ctc chaperone-ctc?)
+  (define elem/c (set-contract-elem/c ctc))
+  (define cmp (set-contract-cmp ctc))
+  (define kind (set-contract-kind ctc))
+  (define lazy? (set-contract-lazy? ctc))
   (lambda (blame)
     (define (method sym c)
       (define name (contract-name c))
@@ -184,15 +260,19 @@
        [set-symmetric-difference!
         (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]))
     (define proj
-        ((contract-projection elem/c)
+      ((contract-late-neg-projection elem/c) (blame-add-element-context blame #f)))
-         (blame-add-context blame "an element of")))
     (lambda (x neg-party)
       (set-contract-check cmp kind blame neg-party x)
       (cond
         [(list? x)
-           (map proj x)]
+         (for/list ([e (in-list x)])
+           (proj e neg-party))]
         [else
-           (do-redirect x neg-party)])))))
+         (do-redirect x neg-party)]))))
+      
+
+(define (blame-add-element-context blame swap?)
+  (blame-add-context blame "an element of" #:swap? swap?))
 
 (define (flat-set-contract-first-order ctc)
   (define set-passes? (set-contract-first-order ctc))
@@ -206,10 +286,9 @@
   (define elem/c (set-contract-elem/c ctc))
   (define cmp (set-contract-cmp ctc))
   (define kind (set-contract-kind ctc))
+  (define mk-elem/c-proj (contract-late-neg-projection elem/c))
   (lambda (b)
-    (define proj
+    (define proj (mk-elem/c-proj (blame-add-context b "an element of")))
-      ((contract-late-neg-projection elem/c)
-       (blame-add-context b "an element of")))
     (lambda (x neg-party)
       (set-contract-check cmp kind b neg-party x)
       (for ([e (in-set x)])