From f0f85549ce069da47e6498b6e6af3ea719f9fc2a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 22 Dec 2015 21:47:26 -0600 Subject: [PATCH] add impersonate-hash-set and chaperone-hash-set --- .../scribblings/reference/sets.scrbl | 53 ++++++++ pkgs/racket-test-core/tests/racket/set.rktl | 36 +++++ racket/collects/racket/private/set-types.rkt | 124 +++++++++++++++++- 3 files changed, 212 insertions(+), 1 deletion(-) diff --git a/pkgs/racket-doc/scribblings/reference/sets.scrbl b/pkgs/racket-doc/scribblings/reference/sets.scrbl index b6e5a99765..8f8aefc29c 100644 --- a/pkgs/racket-doc/scribblings/reference/sets.scrbl +++ b/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 diff --git a/pkgs/racket-test-core/tests/racket/set.rktl b/pkgs/racket-test-core/tests/racket/set.rktl index 50f9525b02..3322a3d996 100644 --- a/pkgs/racket-test-core/tests/racket/set.rktl +++ b/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) diff --git a/racket/collects/racket/private/set-types.rkt b/racket/collects/racket/private/set-types.rkt index dbb587617f..7192549c45 100644 --- a/racket/collects/racket/private/set-types.rkt +++ b/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)