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)
2015-12-27 21:52:16 -06:00 · 2015-12-27 21:52:16 -06:00 · b3d05de304
commit b3d05de304
parent bc12019af4
4 changed files with 303 additions and 94 deletions
--- a/pkgs/racket-doc/scribblings/reference/sets.scrbl
+++ b/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}
--- a/pkgs/racket-test/tests/racket/contract/name.rkt
+++ b/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)]) α))
--- a/pkgs/racket-test/tests/racket/contract/set.rkt
+++ b/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")))
+  
+  )
--- a/racket/collects/racket/set.rkt
+++ b/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)
-         (blame-add-context blame "an element of")))
+      ((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)
-           (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
-      ((contract-late-neg-projection elem/c)
-       (blame-add-context b "an element of")))
+    (define proj (mk-elem/c-proj (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)])