add impersonate-hash-set and chaperone-hash-set

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

@@ -695,6 +695,59 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream].
 
 }
 
+@defproc[(impersonate-hash-set [st mutable-set?]
+                               [ref-proc (-> set? any/c any/c)]
+                               [add-proc (-> set? any/c any/c)]
+                               [remove-proc (-> set? any/c any/c)]
+                               [clear-proc (or/c #f (-> set? any))]
+                               [prop impersonator-property?]
+                               [prop-val any/c] ... ...)
+         (and/c set? impersonator?)]{
+ Impersonates @racket[set], redirecting via the given procedures.
+
+ The @racket[ref-proc] procedure
+ is called whenever an element is extracted from @racket[st]. Its first argument
+ is the set and its second argument is the element being extracted. The
+ result of @racket[ref-proc] is used in place of the extracted argument.
+
+ The @racket[add-proc] procedure is called whenever an element is added to @racket[st].
+ Its first argument is the set and its second argument is the element being
+ added. The result of the procedure is the one actually added to the set.
+
+ The @racket[remove-proc] procedure is called whenever an element is removed
+ from @racket[st]. Its first argument is the set and its second argument is the
+ element being removed. The result of the procedure is the element that actually
+ gets removed from the set.
+ 
+ If @racket[clear-proc] is not @racket[#f], it must accept @racket[set] as
+ an argument and is result is ignored. The fact that @racket[clear-proc]
+ returns (as opposed to raising an exception or otherwise escaping) grants the
+ capability to remove all elements from @racket[st].
+ If @racket[clear-proc] is @racket[#f], then
+ @racket[set-clear] or @racket[set-clear!] on the impersonated set
+ is implemented using @racket[custom-set-first], @racket[custom-set-rest]
+ and @racket[set-remove] or @racket[set-remove!].
+
+ Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to
+ @racket[impersonate-hash-set] must be odd) add @tech{impersonator properties} or
+ override impersonator property values of @racket[st].
+}
+
+@defproc[(chaperone-hash-set [st (or/c set? mutable-set?)]
+                             [ref-proc (-> set? any/c any/c)]
+                             [add-proc (-> set? any/c any/c)]
+                             [remove-proc (-> set? any/c any/c)]
+                             [clear-proc (or/c #f (-> set? any))]
+                             [prop impersonator-property?]
+                             [prop-val any/c] ... ...)
+         (and/c set? chaperone?)]{
+ Chaperones @racket[set]. Like @racket[impersonate-hash-set] but with
+ the constraints that the results of the @racket[ref-proc],
+ @racket[add-proc], and @racket[remove-proc] must be
+ @racket[chaperone-of?] their second arguments. Also, the input
+ may be an @racket[immutable?] set.
+}
+
 @section{Custom Hash Sets}
 
 @defform[(define-custom-set-types name 

pkgs/racket-test-core/tests/racket/set.rktl

@@ -596,4 +596,40 @@
 (test/blame-pos (set-first (app-ctc (set/c string?) (set 1))))
 (test/blame-neg (set-add! (app-ctc (set/c string? #:kind 'mutable) (mutable-set)) 1))
 
+(let ([s (set (list 1 2))])
+  (test #f eq?
+        (set-first (chaperone-hash-set s
+                                       (λ (s l) (apply list l))
+                                       (λ (s l) l)
+                                       (λ (s l) l)))
+        (set-first s)))
+(let ([s (set (list 1 2))])
+  (test #t eq?
+        (set-first (chaperone-hash-set s
+                                       (λ (s l) l)
+                                       (λ (s l) l)
+                                       (λ (s l) l)))
+        (set-first s)))
+(let ([l (list 1 2)])
+  (test #f eq?
+        (set-first (set-add (chaperone-hash-set (set)
+                                                (λ (s l) l)
+                                                (λ (s l) (apply list l))
+                                                (λ (s l) l))
+                            l))
+        l))
+(let ([l (list 1 2)])
+  (test #t eq?
+        (set-first (set-add (chaperone-hash-set (set)
+                                                (λ (s l) l)
+                                                (λ (s l) l)
+                                                (λ (s l) l))
+                            l))
+        l))
+(test #t even?
+      (set-first (impersonate-hash-set (mutable-set 1 3 5)
+                                       (λ (s e) (+ e 1))
+                                       (λ (s l) l)
+                                       (λ (s l) l))))
+
 (report-errs)

racket/collects/racket/private/set-types.rkt

@@ -28,7 +28,10 @@
          make-custom-set-types
          make-custom-set
          make-weak-custom-set
-         make-mutable-custom-set)
+         make-mutable-custom-set
+
+         chaperone-hash-set
+         impersonate-hash-set)
 
 (define (custom-set-empty? s)
   (dprintf "custom-set-empty?\n")
@@ -335,6 +338,125 @@
     [(hash-weak? table) (weak-custom-set (custom-set-spec s) table)]
     [else (mutable-custom-set (custom-set-spec s) table)]))
 
+(define (chaperone-hash-set s
+                            ref-proc
+                            add-proc
+                            remove-proc
+                            .
+                            clear-proc+props)
+  (define-values (clear-proc args)
+    (check-chap/imp-args #f
+                         s
+                         ref-proc
+                         add-proc
+                         remove-proc
+                         clear-proc+props))
+  (define (check-it who original new)
+    (unless (chaperone-of? new original)
+      (error 'chaperone-hash-set
+             "~s did not return a chaperone of ~e, got ~e"
+             who original new))
+    new)
+  (update-custom-set-table
+   s
+   (apply
+    chaperone-hash
+    (custom-set-table s)
+    (λ (hash key) (values (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key))
+                          (λ (hash key val) val)))
+    (λ (hash key val) (values (check-it 'add-proc key (add-proc (update-custom-set-table s hash) key))
+                              val))
+    (λ (hash key) (check-it 'remove-proc key (remove-proc (update-custom-set-table s hash) key)))
+    (λ (hash key) (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key)))
+    (and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash))))
+    args)))
+
+(define (impersonate-hash-set s
+                              ref-proc
+                              add-proc
+                              remove-proc
+                              .
+                              clear-proc+props)
+  (define-values (clear-proc args)
+    (check-chap/imp-args #t
+                         s
+                         ref-proc
+                         add-proc
+                         remove-proc
+                         clear-proc+props))
+  (update-custom-set-table
+   s
+   (apply
+    impersonate-hash
+    (custom-set-table s)
+    (λ (hash key) (values (ref-proc (update-custom-set-table s hash) key) (λ (hash key val) val)))
+    (λ (hash key val) (values (add-proc (update-custom-set-table s hash) key) val))
+    (λ (hash key) (remove-proc (update-custom-set-table s hash) key))
+    (λ (hash key) (ref-proc (update-custom-set-table s hash) key))
+    (and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash))))
+    args)))
+
+(define (check-chap/imp-args impersonate?
+                             s
+                             ref-proc
+                             add-proc
+                             remove-proc
+                             clear-proc+props)
+  (define who (if impersonate? 'impersonate-hash-set 'chaperone-hash-set))
+  (unless (if impersonate? (set-mutable? s) (or (set? s) (set-mutable? s)))
+    (apply raise-argument-error
+           who
+           (if impersonate? "set-mutable?" (format "~s" '(or/c set? set-mutable?)))
+           0 s ref-proc add-proc clear-proc+props))
+  (unless (and (procedure? ref-proc)
+               (procedure-arity-includes? ref-proc 2))
+    (apply raise-argument-error
+           who
+           "(procedure-arity-includes/c 2)"
+           1 s ref-proc add-proc clear-proc+props))
+  (unless (and (procedure? add-proc)
+               (procedure-arity-includes? add-proc 2))
+    (apply raise-argument-error
+           who
+           "(procedure-arity-includes/c 2)"
+           2 s ref-proc add-proc clear-proc+props))
+  (unless (and (procedure? remove-proc)
+               (procedure-arity-includes? remove-proc 2))
+    (apply raise-argument-error
+           who
+           "(procedure-arity-includes/c 2)"
+           3 s ref-proc add-proc clear-proc+props))
+  (unless (null? clear-proc+props)
+    (unless (or (not (car clear-proc+props))
+                (and (procedure? (car clear-proc+props))
+                     (procedure-arity-includes? (car clear-proc+props) 1))
+                (impersonator-property? (car clear-proc+props)))
+      (apply raise-argument-error
+             who
+             (format "~s" `(or/c #f
+                                 (procedure-arity-includes/c 1)
+                                 impersonator-property?))
+             4
+             s ref-proc add-proc clear-proc+props)))
+  (define-values (supplied-clear-proc? clear-proc args)
+    (cond
+      [(null? clear-proc+props) (values #f #f '())]
+      [(impersonator-property? (car clear-proc+props)) (values #f #f clear-proc+props)]
+      [else
+       (values #t
+               (car clear-proc+props)
+               (cdr clear-proc+props))]))
+  (for ([ele (in-list args)]
+        [i (in-naturals)]
+        #:when (even? i))
+    (unless (impersonator-property? ele)
+      (apply raise-argument-error
+             who
+             "impersonator-property?"
+             (+ i (if supplied-clear-proc? 1 0) 4)
+             s ref-proc add-proc clear-proc+props)))
+  (values clear-proc args))
+  
 (define (set-check-compatible name s1 s2)
   (define spec (custom-set-spec s1))
   (unless (and (custom-set? s2)