Fix set/c to conform to hash/c-like restrictions.

Since sets are implemented using the elements as the domain of a hash table,
the following must be true:
 * element contracts for (seteq ...) must be flat
 * element contracts for (seteqv ...) must be flat
 * element contracts for (set ...) must be chaperones, and the resulting
   contract is a chaperone contract

Also, change higher-order set/c contracts to be chaperone contracts
due to the new restrictions.

collects/racket/set.rkt

@@ -85,6 +85,28 @@
                               (lambda (set hc) (add1 (hc (set-ht set)))))
   #:property prop:sequence (lambda (v) (*in-set v)))
 
+;; Not currently exporting this because I'm not sure whether this is the right semantics
+;; for it yet, but it follows most closely the semantics of the old set/c implementation
+;; (while still returning a chaperone).
+(define (chaperone-set s elem-chaperone)
+  (when (or (set-eq? s)
+            (set-eqv? s))
+    (raise-type-error 'chaperone-set "equal-based set" s))
+  (chaperone-struct s
+                    set-ht
+                    (let ([cached-ht #f])
+                      (λ (st ht)
+                        (if cached-ht cached-ht
+                            (let ([new-ht (make-immutable-hash
+                                           (hash-map ht (λ (k v)
+                                                          ;; should be a check of the return here,
+                                                          ;; but until this is exported, it's only
+                                                          ;; used by set/c, which is sure to pass
+                                                          ;; a chaperone-respecting function.
+                                                          (cons (elem-chaperone s k) v))))])
+                              (set! cached-ht new-ht)
+                              new-ht))))))
+
 (define (set . elems)
   (make-set (make-immutable-hash (map (lambda (k) (cons k #t)) elems))))
 (define (seteq . elems)
@@ -328,9 +350,19 @@
         (raise-type-error 'set/c 
                           "(or/c 'dont-care 'equal? 'eq? 'eqv)" 
                           cmp))
-      (if (flat-contract? ctc)
+      (cond
-          (flat-set/c ctc cmp (flat-contract-predicate ctc))
+        [(flat-contract? ctc)
-          (make-set/c ctc cmp)))
+         (flat-set/c ctc cmp (flat-contract-predicate ctc))]
+        [(chaperone-contract? ctc)
+         (if (memq cmp '(eq eqv))
+             (raise-type-error 'set/c
+                               "flat contract"
+                               ctc)
+             (make-set/c ctc cmp))]
+        [else
+         (raise-type-error 'set/c
+                           "chaperone contract"
+                           ctc)]))
     set/c))
 
 (define (set/c-name c)
@@ -347,45 +379,51 @@
        (contract-stronger? (set/c-ctc this)
                            (set/c-ctc that))))
 
+(define (check-set/c ctc)
+  (let ([elem-ctc (set/c-ctc ctc)]
+        [pred (get-pred ctc)]
+        [name (get-name ctc)])
+    (λ (val fail [first-order? #f])
+      (unless (pred val)
+        (fail "expected a <~a>, got ~a" name val))
+      (when first-order?
+        (for ([e (in-set val)])
+          (unless (contract-first-order-passes? elem-ctc e)
+            (fail "expected: ~s, got ~v" (contract-name elem-ctc) e))))
+      #t)))
+
+(define (set/c-first-order ctc)
+  (let ([check (check-set/c ctc)])
+    (λ (val)
+      (let/ec return
+        (check val (λ _ (return #f)) #t)))))
+
 (define (set/c-proj c)
   (let ([proj (contract-projection (set/c-ctc c))]
-        [pred (get-pred c)])
+        [check (check-set/c c)])
     (λ (blame)
       (let ([pb (proj blame)])
         (λ (s)
-          (if (pred s)
+          (check s (λ args (apply raise-blame-error blame s args)))
-              (cond
+          (chaperone-set s (λ (s v) (pb v))))))))
-                [(set-equal? s)
-                 (for/set ((e (in-set s)))
-                          (pb e))]
-                [(set-eqv? s)
-                 (for/seteqv ((e (in-set s)))
-                             (pb e))]
-                [(set-eq? s)
-                 (for/seteq ((e (in-set s)))
-                            (pb e))])
-              (raise-blame-error
-               blame
-               s
-               "expected a <~a>, got ~v" 
-               (get-name c)
-               s)))))))
 
 (define-struct set/c (ctc cmp)
-  #:property prop:contract
+  #:property prop:chaperone-contract
-  (build-contract-property 
+  (build-chaperone-contract-property 
    #:name set/c-name
-   #:first-order get-pred
+   #:first-order set/c-first-order
    #:stronger set/c-stronger
    #:projection set/c-proj))
 
-(define (flat-first-order c)
+(define (flat-set/c-proj c)
-  (let ([inner-pred (flat-set/c-pred c)]
+  (let ([proj (contract-projection (set/c-ctc c))]
-        [pred (get-pred c)])
+        [check (check-set/c c)])
-    (λ (s)
+    (λ (blame)
-      (and (pred s)
+      (let ([pb (proj blame)])
-           (for/and ((e (in-set s)))
+        (λ (val)
-             (inner-pred e))))))
+          (check val (λ args (apply raise-blame-error blame val args)))
+          (for ([e (in-set val)]) (pb e))
+          val)))))
 
 (define-values (flat-set/c flat-set/c-pred)
   (let ()
@@ -393,9 +431,9 @@
       #:property prop:flat-contract
       (build-flat-contract-property 
        #:name set/c-name
-       #:first-order flat-first-order
+       #:first-order set/c-first-order
        #:stronger set/c-stronger
-       #:projection set/c-proj))
+       #:projection flat-set/c-proj))
     (values make-flat-set/c flat-set/c-pred)))
 
 ;; ----

collects/scribblings/reference/sets.scrbl

@@ -207,12 +207,16 @@ Returns @racket[#t] if @racket[st] compares elements with @racket[eqv?],
 Returns @racket[#t] if @racket[st] compares elements with @racket[eq?],
 @racket[#f] if it compares with @racket[equal?] or @racket[eqv?].}
 
-@defproc[(set/c [contract contract?] [#:cmp cmp (or/c 'dont-care 'equal 'eqv 'eq) 'dont-care]) contract?]{
+@defproc[(set/c [contract chaperone-contract?] [#:cmp cmp (or/c 'dont-care 'equal 'eqv 'eq) 'dont-care]) contract?]{
   Constructs a contract that recognizes sets whose elements match @racket[contract].
                                                                  
   If @racket[cmp] is @racket['dont-care], then the equality notion of the set is not considered
   when checking the contract. Otherwise, the contract accepts only sets with the corresponding
   notion of equality.
+  
+  If @racket[cmp] is @racket['eq] or @racket['eqv], then @racket[contract] must be a flat contract.
+  If @racket[contract] is not a flat contract, then @racket[cmp] cannot be @racket['eq] or @racket['eqv]
+  and the resulting contract can only be applied to sets that use @racket[equal?] for equality.
 }
 
 @defproc[(in-set [st set?]) sequence?]{

collects/tests/racket/contract-test.rktl

@@ -9385,6 +9385,19 @@ so that propagation occurs.
                         (struct/c s alpha)))
   
   (ctest #t flat-contract? (set/c integer?))
+  (ctest #f flat-contract? (set/c (-> integer? integer?)))
+  (ctest #t chaperone-contract? (set/c (-> integer? integer?)))
+  
+  ;; Make sure that impersonators cannot be used as the element contract in set/c.
+  (contract-error-test
+   'contract-error-test-set
+   '(let ([proxy-ctc
+           (make-contract
+            #:name 'proxy-ctc
+            #:first-order values
+            #:projection (λ (b) values))])
+      (set/c proxy-ctc))
+   exn:fail?)
           
   ;; Hash contracts with flat domain/range contracts
   (ctest #t contract?              (hash/c any/c any/c #:immutable #f))
@@ -9941,7 +9954,7 @@ so that propagation occurs.
   (test-name '(set/c boolean? #:cmp 'equal) (set/c boolean? #:cmp 'equal))
   (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 'eqv) (set/c (-> char? char?) #:cmp 'eqv))
+  (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal))
   
   ;; NOT YET RELEASED
   #;