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,7 +393,8 @@
   (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)]) α))
   (test-name 'β (let ([α (new-∀/c 'β)]) α))

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
-               #:cmp [cmp 'dont-care]
+  real-set/c-name (set/c elem/c
-               #:kind [kind 'immutable])
+                         #:cmp [cmp 'dont-care]
+                         #: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]
@@ -22,8 +27,8 @@
       [(eqv) set-eqv?]
       [(eq) set-eq?]
       [else (raise-arguments-error 'set/c
-                                  "invalid #:cmp argument"
+                                   "invalid #:cmp argument"
-                                  "#:cmp argument" cmp)]))
+                                   "#:cmp argument" cmp)]))
   (define kind/c
     (case kind
       [(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,83 +126,153 @@
 
 (define (set-contract-late-neg-projection chaperone-ctc?)
   (lambda (ctc)
-    (define elem/c (set-contract-elem/c ctc))
+    (cond
-    (define cmp (set-contract-cmp ctc))
+      [(allows-generic-sets? ctc)
-    (define kind (set-contract-kind ctc))
+       (generic-set-late-neg-projection ctc chaperone-ctc?)]
-    (lambda (blame)
+      [else
-      (define (method sym c)
+       (hash-set-late-neg-projection ctc chaperone-ctc?)])))
-        (define name (contract-name c))
+
-        (define str (format "method ~a with contract ~.s" sym name))
+(define (allows-generic-sets? ctc)
-        (define b2 (blame-add-context blame str))
+  (and (equal? 'dont-care (set-contract-kind ctc))
-        ((contract-late-neg-projection c) b2))
+       (equal? 'dont-care (set-contract-cmp ctc))))
-      (define-syntax (redirect stx)
+
-        (syntax-case stx ()
+(define (hash-set-late-neg-projection ctc chaperone-ctc?)
-          [(_ [id expr] ...)
+  (define elem/c (set-contract-elem/c ctc))
-           (with-syntax ([(proj-id ...) (generate-temporaries #'(id ...))])
+  (define cmp (set-contract-cmp ctc))
-             #'(let ([proj-id (method 'id expr)] ...)
+  (define kind (set-contract-kind ctc))
-                 (λ (x neg-party)
+  (define late-neg-ele-proj (contract-late-neg-projection elem/c))
-                   (redirect-generics chaperone-ctc?
+  (define lazy? (set-contract-lazy? ctc))
-                                      gen:set x [id (λ (x) (proj-id x neg-party))] ...))))]))
+  (λ (blame)
-      (define me (if chaperone-contract?
+    (define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f)))
-                     (make-chaperone-contract
+    (define late-neg-neg-proj (late-neg-ele-proj (blame-add-element-context blame #t)))
-                      #:name (set-contract-name ctc)
+    (define set/c-lazy-late-neg-proj
-                      #:stronger set-contract-stronger
+      (λ (val neg-party)
-                      #:late-neg-projection
+        (set-contract-check cmp kind blame neg-party val)
-                      (λ (blame) (λ (val neg-party) (do-redirect val neg-party))))
+        (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
-                     (make-contract
-                      #:name (set-contract-name ctc)
-                      #:stronger set-contract-stronger
-                      #:late-neg-projection
-                      (λ (blame) (λ (val neg-party) (do-redirect val neg-party))))))
-      (define do-redirect
-        (redirect
-         [set-member? (-> generic-set? elem/c boolean?)]
-         [set-empty? (or/c (-> generic-set? boolean?) #f)]
-         [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)]
-         [set=? (or/c (-> generic-set? me boolean?) #f)]
-         [subset? (or/c (-> generic-set? me boolean?) #f)]
-         [proper-subset? (or/c (-> generic-set? me boolean?) #f)]
-         [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)]
-         [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)]
-         [set-copy (or/c (-> generic-set? generic-set?) #f)]
-         [in-set (or/c (-> generic-set? sequence?) #f)]
-         [set->list (or/c (-> generic-set? (listof elem/c)) #f)]
-         [set->stream (or/c (-> generic-set? stream?) #f)]
-         [set-first (or/c (-> generic-set? elem/c) #f)]
-         [set-rest (or/c (-> generic-set? me) #f)]
-         [set-add (or/c (-> generic-set? elem/c me) #f)]
-         [set-remove (or/c (-> generic-set? elem/c me) #f)]
-         [set-clear (or/c (-> generic-set? me) #f)]
-         [set-copy-clear (or/c (-> generic-set? generic-set?) #f)]
-         [set-union
-          (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
-         [set-intersect
-          (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
-         [set-subtract
-          (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
-         [set-symmetric-difference
-          (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
-         [set-add! (or/c (-> generic-set? elem/c void?) #f)]
-         [set-remove! (or/c (-> generic-set? elem/c void?) #f)]
-         [set-clear! (or/c (-> generic-set? void?) #f)]
-         [set-union!
-          (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
-         [set-intersect!
-          (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
-         [set-subtract!
-          (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
-         [set-symmetric-difference!
-          (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]))
-      (define proj
-        ((contract-projection elem/c)
-         (blame-add-context blame "an element of")))
-      (lambda (x neg-party)
-        (set-contract-check cmp kind blame neg-party x)
         (cond
-          [(list? x)
+          [(set? val)
-           (map proj x)]
+           (chaperone-hash-set
+            val
+            pos-interpose
+            (λ (val ele) ele)
+            pos-interpose
+            impersonator-prop:contracted
+            ctc)]
           [else
-           (do-redirect x neg-party)])))))
+           (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))
+      (define str (format "method ~a with contract ~.s" sym name))
+      (define b2 (blame-add-context blame str))
+      ((contract-late-neg-projection c) b2))
+    (define-syntax (redirect stx)
+      (syntax-case stx ()
+        [(_ [id expr] ...)
+         (with-syntax ([(proj-id ...) (generate-temporaries #'(id ...))])
+           #'(let ([proj-id (method 'id expr)] ...)
+               (λ (x neg-party)
+                 (redirect-generics chaperone-ctc?
+                                    gen:set x [id (λ (x) (proj-id x neg-party))] ...))))]))
+    (define me (if chaperone-contract?
+                   (make-chaperone-contract
+                    #:name (set-contract-name ctc)
+                    #:stronger set-contract-stronger
+                    #:late-neg-projection
+                    (λ (blame) (λ (val neg-party) (do-redirect val neg-party))))
+                   (make-contract
+                    #:name (set-contract-name ctc)
+                    #:stronger set-contract-stronger
+                    #:late-neg-projection
+                    (λ (blame) (λ (val neg-party) (do-redirect val neg-party))))))
+    (define do-redirect
+      (redirect
+       [set-member? (-> generic-set? elem/c boolean?)]
+       [set-empty? (or/c (-> generic-set? boolean?) #f)]
+       [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)]
+       [set=? (or/c (-> generic-set? me boolean?) #f)]
+       [subset? (or/c (-> generic-set? me boolean?) #f)]
+       [proper-subset? (or/c (-> generic-set? me boolean?) #f)]
+       [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)]
+       [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)]
+       [set-copy (or/c (-> generic-set? generic-set?) #f)]
+       [in-set (or/c (-> generic-set? sequence?) #f)]
+       [set->list (or/c (-> generic-set? (listof elem/c)) #f)]
+       [set->stream (or/c (-> generic-set? stream?) #f)]
+       [set-first (or/c (-> generic-set? elem/c) #f)]
+       [set-rest (or/c (-> generic-set? me) #f)]
+       [set-add (or/c (-> generic-set? elem/c me) #f)]
+       [set-remove (or/c (-> generic-set? elem/c me) #f)]
+       [set-clear (or/c (-> generic-set? me) #f)]
+       [set-copy-clear (or/c (-> generic-set? generic-set?) #f)]
+       [set-union
+        (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
+       [set-intersect
+        (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
+       [set-subtract
+        (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
+       [set-symmetric-difference
+        (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
+       [set-add! (or/c (-> generic-set? elem/c void?) #f)]
+       [set-remove! (or/c (-> generic-set? elem/c void?) #f)]
+       [set-clear! (or/c (-> generic-set? void?) #f)]
+       [set-union!
+        (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
+       [set-intersect!
+        (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
+       [set-subtract!
+        (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
+       [set-symmetric-difference!
+        (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]))
+    (define proj
+      ((contract-late-neg-projection elem/c) (blame-add-element-context blame #f)))
+    (lambda (x neg-party)
+      (set-contract-check cmp kind blame neg-party x)
+      (cond
+        [(list? x)
+         (for/list ([e (in-list x)])
+           (proj e neg-party))]
+        [else
+         (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)])