suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Clean up chaperone-hash-set and impersonate-hash-set and adjust set/c to match

Browse Source 
Made the hash-set chaperones essentially forward the hash chaperone
operations, but now explain them all in terms of set-based operations
in the docs.

Also adjusted value-blame and has-blame? to support late-neg projections
This commit is contained in:
Robby Findler 2016-01-03 15:15:11 -06:00
parent 77a76a7953
commit 1c431e6f4d
9 changed files with 551 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -2384,10 +2384,17 @@ is expected to be the contract on the value).
@defthing[impersonator-prop:blame impersonator-property?] @defthing[impersonator-prop:blame impersonator-property?]
)]{ )]{
These properties attach a blame information to the protected structure, These properties attach a blame information to the protected structure,
chaperone, or impersonator value. The function @racket[blame-contract?] chaperone, or impersonator value. The function @racket[has-blame?]
returns @racket[#t] for values that have one of these properties, and returns @racket[#t] for values that have one of these properties, and
@racket[blame-contract] extracts the value from the property (which @racket[value-blame] extracts the value from the property.
is expected to be the blame record for the contract on the value).
The value is expected to be the blame record for the contract on the value or
a @racket[cons]-pair of a blame record with a missing party and the missing
party. The @racket[value-blame] function reassembles the arguments of the pair
into a complete blame record using @racket[blame-add-missing-party]. If
the value has one of the properties, but the value is not a blame object
or a pair whose @racket[car] position is a blame object, then @racket[has-blame?]
returns @racket[#f] but @racket[value-blame] returns @racket[#f].
} }
@deftogether[( @deftogether[(

91
pkgs/racket-doc/scribblings/reference/sets.scrbl
View File

@ -206,7 +206,8 @@ named by the @racket[sym]s.
'immutable] 'immutable]
[#:lazy? lazy? any/c [#:lazy? lazy? any/c
(not (and (equal? kind 'immutable) (not (and (equal? kind 'immutable)
(flat-contract? elem/c)))]) (flat-contract? elem/c)))]
[#:equal-key/c equal-key/c contract? any/c])
contract?]{ contract?]{
Constructs a contract that recognizes sets whose elements match Constructs a contract that recognizes sets whose elements match
@ -244,8 +245,12 @@ named by the @racket[sym]s.
@racket['mutable-or-weak]) and @racket[lazy?] is @racket[#f], then the elements @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. 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 The @racket[equal-key/c] contract is used when values are passed to the comparison
contract}, @racket[lazy?] is @racket[#f], and @racket[kind] is @racket['immutable]. and hashing functions used internally.
The result contract will be a @tech{flat contract} when @racket[elem/c]
and @racket[equal-key/c] are both @tech{flat contracts},
@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 The result will be a @tech{chaperone contract} when @racket[elem/c] is a
@tech{chaperone contract}. @tech{chaperone contract}.
} }
@ -716,59 +721,73 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream].
} }
@defproc[(impersonate-hash-set [st mutable-set?] @defproc[(impersonate-hash-set [st (or/c mutable-set? weak-set?)]
[ref-proc (or/c #f (-> set? any/c any/c))] [inject-proc (or/c #f (-> set? any/c any/c))]
[add-proc (or/c #f (-> set? any/c any/c))] [add-proc (or/c #f (-> set? any/c any/c))]
[remove-proc (or/c #f (-> set? any/c any/c))] [shrink-proc (or/c #f (-> set? any/c any/c))]
[extract-proc (or/c #f (-> set? any/c any/c))]
[clear-proc (or/c #f (-> set? any)) #f] [clear-proc (or/c #f (-> set? any)) #f]
[equal-key-proc (or/c #f (-> set? any/c any/c)) #f]
[prop impersonator-property?] [prop impersonator-property?]
[prop-val any/c] ... ...) [prop-val any/c] ... ...)
(and/c set? impersonator?)]{ (and/c (or/c mutable-set? weak-set?) impersonator?)]{
Impersonates @racket[st], redirecting via the given procedures. Impersonates @racket[st], redirecting various set operations via the given procedures.
The @racket[ref-proc] procedure The @racket[inject-proc] procedure
is called whenever an element is extracted from @racket[st]. Its first argument is called whenever an element is temporarily put into the set for the purposes
is the set and its second argument is the element being extracted. The of comparing it with other elements that may already be in the set. For example,
result of @racket[ref-proc] is used in place of the extracted argument. when evaluating @racket[(set-member? s e)], @racket[e] will be passed to the
@racket[inject-proc] before comparing it with other elements of @racket[s].
The @racket[add-proc] procedure is called whenever an element is added to @racket[st]. The @racket[add-proc] procedure is called when adding an element to a set, e.g.,
Its first argument is the set and its second argument is the element being via @racket[set-add] or @racket[set-add!]. The result of the @racket[add-proc] is
added. The result of the procedure is the one actually added to the set. stored in the set.
The @racket[remove-proc] procedure is called whenever an element is removed The @racket[shrink-proc] procedure is called when building a new set with
from @racket[st]. Its first argument is the set and its second argument is the one fewer element. For example, when evaluating @racket[(set-remove s e)]
element being removed. The result of the procedure is the element that actually or @racket[(set-remove! s e)],
gets removed from the set. an element is removed from a set, e.g.,
via @racket[set-remove] or @racket[set-remove!]. The result of the @racket[shrink-proc]
is the element actually removed from the set.
If any of the @racket[ref-proc], @racket[add-proc], or @racket[remove-proc] arguments The @racket[extract-proc] procedure is called when an element is pulled out of
is @racket[#f], then all three must be and there must be at least one property supplied. a set, e.g., by @racket[set-first]. The result of the @racket[extract-proc] is
In that case, a more efficient chaperone wrapper is created. the element actually produced by from the set.
If @racket[clear-proc] is not @racket[#f], it must accept @racket[set] as The @racket[clear-proc] is called by @racket[set-clear] and @racket[set-clear!]
an argument and is result is ignored. The fact that @racket[clear-proc] and if it returns (as opposed to escaping, perhaps via raising an exception),
returns (as opposed to raising an exception or otherwise escaping) grants the the clearing operation is permitted. Its result is ignored. If @racket[clear-proc]
capability to remove all elements from @racket[st]. is @racket[#f], then clearing is done element by element (via calls into the other
If @racket[clear-proc] is @racket[#f], then supplied procedures).
@racket[set-clear] or @racket[set-clear!] on the impersonated set
is implemented using @racket[custom-set-first], @racket[custom-set-rest] The @racket[equal-key-proc] is called when an element's hash code is needed of when an
and @racket[set-remove] or @racket[set-remove!]. element is supplied to the underlying equality in the set. The result of
@racket[equal-key-proc] is used when computing the hash or comparing for equality.
If any of the @racket[inject-proc], @racket[add-proc], @racket[shrink-proc], or
@racket[extract-proc] arguments are @racket[#f], then they all must be @racket[#f],
the @racket[clear-proc] and @racket[equal-key-proc] must also be @racket[#f],
and there must be at least one property supplied.
Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to 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 @racket[impersonate-hash-set] must be odd) add @tech{impersonator properties} or
override impersonator property values of @racket[st]. override impersonator property values of @racket[st].
} }
@defproc[(chaperone-hash-set [st (or/c set? mutable-set?)] @defproc[(chaperone-hash-set [st (or/c set? mutable-set? weak-set?)]
[ref-proc (or/c #f (-> set? any/c any/c))] [inject-proc (or/c #f (-> set? any/c any/c))]
[add-proc (or/c #f (-> set? any/c any/c))] [add-proc (or/c #f (-> set? any/c any/c))]
[remove-proc (or/c #f (-> set? any/c any/c))] [shrink-proc (or/c #f (-> set? any/c any/c))]
[extract-proc (or/c #f (-> set? any/c any/c))]
[clear-proc (or/c #f (-> set? any)) #f] [clear-proc (or/c #f (-> set? any)) #f]
[equal-key-proc (or/c #f (-> set? any/c any/c)) #f]
[prop impersonator-property?] [prop impersonator-property?]
[prop-val any/c] ... ...) [prop-val any/c] ... ...)
(and/c set? chaperone?)]{ (and/c (or/c set? mutable-set? weak-set?) chaperone?)]{
Chaperones @racket[st]. Like @racket[impersonate-hash-set] but with Chaperones @racket[st]. Like @racket[impersonate-hash-set] but with
the constraints that the results of the @racket[ref-proc], the constraints that the results of the @racket[inject-proc],
@racket[add-proc], and @racket[remove-proc] must be @racket[add-proc], @racket[shrink-proc], @racket[extract-proc], and
@racket[equal-key-proc] must be
@racket[chaperone-of?] their second arguments. Also, the input @racket[chaperone-of?] their second arguments. Also, the input
may be an @racket[immutable?] set. may be an @racket[immutable?] set.
} }

320
pkgs/racket-test-core/tests/racket/set.rktl
View File

@ -561,153 +561,223 @@
(add1 i))) (add1 i)))
;; ---------------------------------------- ;; ----------------------------------------
;; set/c tests ;; chaperone-hash-set tests
(err/rt-test (set/c '(not a contract))) (let ()
(err/rt-test (set/c any/c #:cmp 'not-a-comparison))
(err/rt-test (set/c any/c #:kind 'not-a-kind-of-set))
(err/rt-test (set/c (-> integer? string?) #:cmp 'eq))
(err/rt-test (set/c (-> integer? string?) #:cmp 'eqv))
(define (app-ctc ctc value) ;; adds a tracing chaperone to 's', runs 'go' on it, and returns the trace
(contract ctc value 'positive 'negative)) (define (counting-chaperone s go equal-key?)
(define trace '())
(define (add-to-trace ele) (set! trace (cons ele trace)))
(define (count name)
(procedure-rename
(λ (s ele) (add-to-trace (list name ele)) ele)
name))
(go
(chaperone-hash-set
s
(count 'inject)
(count 'add)
(count 'shrink)
(count 'extract)
(λ (s) (add-to-trace 'clear))
(if equal-key? (count 'equal-key) (λ (s ele) ele))))
(reverse trace))
(define (positive-error? exn) (test '((extract 1))
(and exn:fail:contract? counting-chaperone
(regexp-match? "blaming: positive" (exn-message exn)))) (set 1)
(define (negative-error? exn) (λ (s) (set-first s))
(and exn:fail:contract? #f)
(regexp-match? "blaming: negative" (exn-message exn)))) (test '((add 1))
counting-chaperone
(define-syntax-rule (test/blame-pos e) (set)
(thunk-error-test (lambda () e) #'e positive-error?)) (λ (s) (set-add s 1))
(define-syntax-rule (test/blame-neg e) #f)
(thunk-error-test (lambda () e) #'e negative-error?)) (test '((extract 1))
counting-chaperone
;; check dont-care defaults (mutable-set 1)
(test #t set? (app-ctc (set/c any/c) (set))) (λ (s) (set-first s))
(test #t set? (app-ctc (set/c any/c) (seteq))) #f)
(test '((extract 1))
(test/blame-pos (app-ctc (set/c any/c) (mutable-set))) ; check immutable default counting-chaperone
(test/blame-pos (app-ctc (set/c any/c #:cmp 'eq) (set))) (weak-set 1)
(test/blame-pos (app-ctc (set/c any/c #:kind 'mutable) (set))) (λ (s) (set-first s))
(test/blame-pos (app-ctc (set/c string? #:kind 'immutable) (set 1))) #f)
(test/blame-pos (app-ctc (set/c string?) (set 1))) (test '((add 2))
(test/blame-pos (set-first (app-ctc (set/c string?) (set 1)))) counting-chaperone
(test/blame-neg (set-add! (app-ctc (set/c string? #:kind 'mutable) (mutable-set)) 1)) (mutable-set 1)
(λ (s) (set-add! s 2))
(let ([s (set (list 1 2))]) #f)
(test #f eq? (test '((inject 2))
(set-first (chaperone-hash-set s counting-chaperone
(λ (s l) (apply list l)) (mutable-set 1)
(λ (s l) l) (λ (s) (set-member? s 2))
(λ (s l) l))) #f)
(set-first s))) (test '((inject 1))
(let ([s (set (list 1 2))]) counting-chaperone
(test #t eq? (mutable-set 1)
(set-first (chaperone-hash-set s (λ (s) (set-member? s 1))
(λ (s l) l) #f)
(λ (s l) l) (test '((shrink 1))
(λ (s l) l))) counting-chaperone
(set-first s))) (set 1)
(let ([l (list 1 2)]) (λ (s) (set-remove s 1))
(test #f eq? #f)
(set-first (set-add (chaperone-hash-set (set) (test '((shrink 1))
(λ (s l) l) counting-chaperone
(λ (s l) (apply list l)) (mutable-set 1)
(λ (s l) l)) (λ (s) (set-remove! s 1))
l)) #f)
l)) (test '((inject 2) (equal-key 2) (equal-key 2))
(let ([l (list 1 2)]) counting-chaperone
(test #t eq? (set 2)
(set-first (set-add (chaperone-hash-set (set) (λ (s) (set-member? s 2))
(λ (s l) l) #t)
(λ (s l) l) (test '((extract 0))
(λ (s l) l)) counting-chaperone
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))))
(test #t even?
(set-first (impersonate-hash-set (weak-set 1 3 5)
(λ (s e) (+ e 1))
(λ (s l) l)
(λ (s l) l))))
(test #t zero?
(let ([ele #f])
(set-first (impersonate-hash-set (weak-set 0)
(λ (s e) (set! ele e))
(λ (s l) l)
(λ (s l) l)))
ele))
(test #t zero?
(let ([ele #f])
(define-custom-set-types set2 equal? equal-hash-code)
(define ele #f)
(set-first
(chaperone-hash-set (set-add (make-immutable-set2) 0)
(λ (s e) (set! ele e) e)
(λ (s l) l)
(λ (s l) l)))
ele))
(test #t zero?
(let ([ele #f])
(define-custom-set-types set2 equal? equal-hash-code)
(define ele #f)
(define s (make-weak-set2))
(set-add! s 0)
(set-first
(impersonate-hash-set s
(λ (s e) (set! ele e) e)
(λ (s l) l)
(λ (s l) l)))
ele))
(test #t zero?
(let () (let ()
(define-custom-set-types set2 equal? equal-hash-code) (define-custom-set-types set2 equal? equal-hash-code)
(set-first (define ele #f)
(set-add (chaperone-hash-set (set-add (make-immutable-set2) 0))
(make-immutable-set2) (λ (s) (set-first s))
(λ (a b) b) #f)
(λ (a b) b) (test '((extract 0))
(λ (a b) b)) counting-chaperone
0)))) (let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define s (make-weak-set2))
(set-add! s 0)
s)
(λ (s) (set-first s))
#f)
(test '((add 0) (remove 0))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(make-immutable-set2))
(λ (s)
(set-first (set-add s 0)))
#f)
(test '((extract 1))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define ele #f)
(set-add (make-immutable-set2) 1))
(λ (s) (set-first s))
#f)
(test '((add 1))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define ele #f)
(make-immutable-set2))
(λ (s) (set-add s 1))
#f)
(test '((remove 1))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define s (make-mutable-set2))
(set-add! s 1)
s)
(λ (s) (set-first s))
#f)
(test '((remove 1))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define s (make-weak-set2))
(set-add! s 1)
s)
(λ (s) (set-first s))
#f)
(test '((add 2))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define s (make-mutable-set2))
(set-add! s 1)
s)
(λ (s) (set-add! s 2))
#f)
(test '((inject 2))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define s (make-mutable-set2))
(set-add! s 1)
s)
(λ (s) (set-member? s 2))
#f)
(test '((inject 1))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define s (make-mutable-set2))
(set-add! s 1)
s)
(λ (s) (set-member? s 1))
#f)
(test '((shrink 1))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define ele #f)
(set-add (make-immutable-set2) 1))
(λ (s) (set-remove s 1))
#f)
(test '((inject 2) (equal-key 2) (equal-key 2))
counting-chaperone
(let ()
(define-custom-set-types set2 equal? equal-hash-code)
(define ele #f)
(set-add (make-immutable-set2) 2))
(λ (s) (set-member? s 2))
#t))
(let ([s (set 1 2 3)])
(test #t equal?
(chaperone-hash-set s (λ (x y) y) (λ (x y) y) (λ (x y) y) (λ (x y) y))
s))
(let ([s (set 1 2 3)])
(test #t equal?
s
(chaperone-hash-set s (λ (x y) y) (λ (x y) y) (λ (x y) y) (λ (x y) y))))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) (let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)]) (make-impersonator-property 'p)])
(let ([s (chaperone-hash-set (set) (λ (s l) l) (λ (s l) l) (λ (s l) l) impersonator-prop:p 11)]) (let ([s (chaperone-hash-set (set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l)
(test #t has-impersonator-prop:p? s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)])
(let ([s (chaperone-hash-set (set) (λ (s l) l) (λ (s l) l) (λ (s l) l) impersonator-prop:p 11)])
(test 11 get-impersonator-prop:p s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)])
(let ([s (impersonate-hash-set (weak-set) (λ (s l) l) (λ (s l) l) (λ (s l) l)
impersonator-prop:p 11)]) impersonator-prop:p 11)])
(test #t has-impersonator-prop:p? s))) (test #t has-impersonator-prop:p? s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) (let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)]) (make-impersonator-property 'p)])
(let ([s (impersonate-hash-set (mutable-set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (let ([s (chaperone-hash-set (set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l)
impersonator-prop:p 11)]) impersonator-prop:p 11)])
(test 11 get-impersonator-prop:p s))) (test 11 get-impersonator-prop:p s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) (let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)]) (make-impersonator-property 'p)])
(let ([s (chaperone-hash-set (set) #f #f #f impersonator-prop:p 11)]) (let ([s (impersonate-hash-set (weak-set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l)
impersonator-prop:p 11)])
(test #t has-impersonator-prop:p? s))) (test #t has-impersonator-prop:p? s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) (let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)]) (make-impersonator-property 'p)])
(let ([s (impersonate-hash-set (mutable-set) #f #f #f impersonator-prop:p 11)]) (let ([s (impersonate-hash-set (mutable-set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l)
impersonator-prop:p 11)])
(test 11 get-impersonator-prop:p s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)])
(let ([s (chaperone-hash-set (set) #f #f #f #f impersonator-prop:p 11)])
(test #t has-impersonator-prop:p? s)))
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
(make-impersonator-property 'p)])
(let ([s (impersonate-hash-set (mutable-set) #f #f #f #f impersonator-prop:p 11)])
(test 11 get-impersonator-prop:p s))) (test 11 get-impersonator-prop:p s)))
(report-errs) (report-errs)

75
pkgs/racket-test/tests/racket/contract/set.rkt
View File

@ -4,6 +4,59 @@
(parameterize ([current-contract-namespace (parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/set)]) (make-basic-contract-namespace 'racket/set)])
(test/spec-passed/result
'set/c.0.1
'(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))])
(set/c '(not a contract)))
#t)
(test/spec-passed/result
'set/c.0.2
'(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))])
(set/c any/c #:cmp 'not-a-comparison))
#t)
(test/spec-passed/result
'set/c.0.3
'(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))])
(set/c any/c #:kind 'not-a-kind-of-set))
#t)
(test/spec-passed/result
'set/c.0.4
'(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))])
(set/c (-> integer? string?) #:cmp 'eq))
#t)
(test/spec-passed/result
'set/c.0.5
'(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))])
(set/c (-> integer? string?) #:cmp 'eqv))
#t)
;; check dont-care defaults
(test/spec-passed/result
'set/c.0.6
'(set? (contract (set/c any/c) (set) 'pos 'neg))
#t)
(test/spec-passed/result
'set/c.0.7
'(set? (contract (set/c any/c) (seteq) 'pos 'neg))
#t)
(test/pos-blame 'set/c.0.8
'(contract (set/c any/c) (mutable-set) 'pos 'neg)) ; check immutable default
(test/pos-blame 'set/c.0.9
'(contract (set/c any/c #:cmp 'eq) (set) 'pos 'neg))
(test/pos-blame 'set/c.0.10
'(contract (set/c any/c #:kind 'mutable) (set) 'pos 'neg))
(test/pos-blame 'set/c.0.11
'(contract (set/c string? #:kind 'immutable) (set 1) 'pos 'neg))
(test/pos-blame 'set/c.0.12
'(contract (set/c string?) (set 1) 'pos 'neg))
(test/pos-blame 'set/c.0.13
'(set-first (contract (set/c string?) (set 1) 'pos 'neg)))
(test/neg-blame 'set/c.0.14
'(set-add! (contract (set/c string? #:kind 'mutable) (mutable-set) 'pos 'neg)
1))
(test/spec-passed/result (test/spec-passed/result
'set/c1 'set/c1
'(contract (set/c integer?) '(contract (set/c integer?)
@ -236,7 +289,7 @@
add1))) add1)))
(test/spec-passed (test/spec-passed
'set/c30 'set/c31
'(let () '(let ()
(define-custom-set-types set2 equal?) (define-custom-set-types set2 equal?)
(set-add (set-add
@ -245,4 +298,24 @@
'pos 'neg) 'pos 'neg)
add1))) add1)))
(test/pos-blame
'set/c32
'(let ()
(define-custom-set-types set2 equal? (λ (p) (p #f) 0))
(set-add (contract (set/c (-> integer? boolean?)
#:equal-key/c (-> integer? boolean?))
(make-immutable-set2)
'pos 'neg)
(λ (x) (zero? (+ x 1))))))
(test/spec-passed
'set/c33
'(let ()
(define-custom-set-types set2 equal? (λ (p) (p 0) 0))
(set-add (contract (set/c (-> integer? boolean?)
#:equal-key/c (-> integer? boolean?))
(make-immutable-set2)
'pos 'neg)
(λ (x) (zero? (+ x 1))))))
) )

4
pkgs/racket-test/tests/racket/contract/test-util.rkt
View File

@ -163,7 +163,7 @@
name name
(contract-eval #:test-case-name name (contract-eval #:test-case-name name
`(with-handlers ((exn:fail:syntax? `(with-handlers ((exn:fail:syntax?
(lambda (x) (and (regexp-match ,reg (exn-message x)) #t)))) (lambda (x) (regexp-match? ,reg (exn-message x)))))
(eval ',exp))))) (eval ',exp)))))
;; test/spec-passed : symbol sexp -> void ;; test/spec-passed : symbol sexp -> void
@ -281,7 +281,7 @@
(define (good-thing? l) (define (good-thing? l)
(for/or ([x (in-list l)]) (for/or ([x (in-list l)])
(and (symbol? x) (and (symbol? x)
(regexp-match #rx"contract" (symbol->string x))))) (regexp-match? #rx"contract" (symbol->string x)))))
(cond (cond
[(and (pair? body) [(and (pair? body)
(eq? (car body) 'require) (eq? (car body) 'require)

41
pkgs/racket-test/tests/racket/contract/value-contract.rkt
View File

@ -2,7 +2,8 @@
(require "test-util.rkt") (require "test-util.rkt")
(parameterize ([current-contract-namespace (parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/unit 'racket/class 'racket/contract)]) (make-basic-contract-namespace 'racket/unit 'racket/class
'racket/contract 'racket/set)])
(ctest #f value-contract #f) (ctest #f value-contract #f)
(ctest #f value-contract (λ (x) x)) (ctest #f value-contract (λ (x) x))
@ -58,7 +59,7 @@
#t) #t)
(test/spec-passed/result (test/spec-passed/result
'value-blame 'value-blame.1
'(let () '(let ()
(define f (define f
(contract (-> integer? integer?) (λ (x) x) 'pos 'neg)) (contract (-> integer? integer?) (λ (x) x) 'pos 'neg))
@ -67,4 +68,40 @@
(or (and (has-blame? f) (or (and (has-blame? f)
(blame-positive (value-blame f))) (blame-positive (value-blame f)))
'pos)) 'pos))
'pos)
(test/spec-passed/result
'value-blame.2
'(let ()
(define f
(contract (-> integer? integer?) (λ (x) x) 'pos 'neg))
;; opt/c version doesn't yet have blame, so
;; we require only that when there is blame, that the blame is right.
(or (and (has-blame? f)
(blame-negative (value-blame f)))
'neg))
'neg)
(test/spec-passed/result
'value-blame.3
'(let ()
(define f
(contract (set/c (-> integer? integer?) #:kind 'mutable) (mutable-set) 'pos 'neg))
;; opt/c version doesn't yet have blame, so
;; we require only that when there is blame, that the blame is right.
(or (and (has-blame? f)
(blame-positive (value-blame f)))
'pos)) 'pos))
'pos)
(test/spec-passed/result
'value-blame.4
'(let ()
(define f
(contract (set/c (-> integer? integer?) #:kind 'mutable) (mutable-set) 'pos 'neg))
;; opt/c version doesn't yet have blame, so
;; we require only that when there is blame, that the blame is right.
(or (and (has-blame? f)
(blame-negative (value-blame f)))
'neg))
'neg))

6
racket/collects/racket/contract/private/guts.rkt
View File

@ -139,12 +139,18 @@
(has-impersonator-prop:blame? v))) (has-impersonator-prop:blame? v)))
(define (value-blame v) (define (value-blame v)
(define bv
(cond (cond
[(has-prop:blame? v) [(has-prop:blame? v)
(get-prop:blame v)] (get-prop:blame v)]
[(has-impersonator-prop:blame? v) [(has-impersonator-prop:blame? v)
(get-impersonator-prop:blame v)] (get-impersonator-prop:blame v)]
[else #f])) [else #f]))
(cond
[(and (pair? bv) (blame? (car bv)))
(blame-add-missing-party (car bv) (cdr bv))]
[(blame? bv) bv]
[else #f]))
(define-values (prop:contracted has-prop:contracted? get-prop:contracted) (define-values (prop:contracted has-prop:contracted? get-prop:contracted)
(let-values ([(prop pred get) (let-values ([(prop pred get)

257
racket/collects/racket/private/set-types.rkt
View File

@ -338,19 +338,9 @@
[(hash-weak? table) (weak-custom-set (custom-set-spec s) table)] [(hash-weak? table) (weak-custom-set (custom-set-spec s) table)]
[else (mutable-custom-set (custom-set-spec s) table)])) [else (mutable-custom-set (custom-set-spec s) table)]))
(define (chaperone-hash-set s (define (chaperone-hash-set s inject-proc add-proc shrink-proc extract-proc . clear-proc+props)
ref-proc (define-values (clear-proc equal-key-proc prop-args)
add-proc (check-chap/imp-args #f s inject-proc add-proc shrink-proc extract-proc clear-proc+props))
remove-proc
.
clear-proc+props)
(define-values (clear-proc prop-args)
(check-chap/imp-args #f
s
ref-proc
add-proc
remove-proc
clear-proc+props))
(define (check-it who original new) (define (check-it who original new)
(unless (chaperone-of? new original) (unless (chaperone-of? new original)
(error 'chaperone-hash-set (error 'chaperone-hash-set
@ -358,105 +348,62 @@
who original new)) who original new))
new) new)
(define (chaperone-hash-set-hash-ref-proc hash key)
(values (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key))
(λ (hash key val) val)))
(define (chaperone-hash-set-hash-set-proc hash key val)
(values (check-it 'add-proc key (add-proc (update-custom-set-table s hash) key))
val))
(define (chaperone-hash-set-hash-remove-proc hash key)
(check-it 'remove-proc key (remove-proc (update-custom-set-table s hash) key)))
(define (chaperone-hash-set-hash-key-proc hash key)
(check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key)))
(define chaperone-hash-set-hash-clear-proc
(and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))
(add-impersonator-properties (add-impersonator-properties
(if ref-proc (if inject-proc
(chap-or-imp-hash-set s (chap-or-imp-hash-set s
chaperone-hash chaperone-hash
chaperone-hash-set-hash-ref-proc (λ (ele) (check-it 'in-proc ele (inject-proc s ele)))
chaperone-hash-set-hash-set-proc (λ (ele) (check-it 'add-proc ele (add-proc s ele)))
chaperone-hash-set-hash-remove-proc (λ (ele) (check-it 'shrink-proc ele (shrink-proc s ele)))
chaperone-hash-set-hash-key-proc (λ (ele) (check-it 'extract-proc ele (extract-proc s ele)))
chaperone-hash-set-hash-clear-proc) (and clear-proc (λ () (clear-proc s)))
(λ (ele) (equal-key-proc s ele)))
s) s)
prop-args)) prop-args))
(define (chap-or-imp-hash-set s (define (impersonate-hash-set s inject-proc add-proc shrink-proc extract-proc . clear-proc+props)
chaperone-or-impersonate-hash (define-values (clear-proc equal-key-proc prop-args)
c/i-hash-set-hash-ref-proc (check-chap/imp-args #t s inject-proc add-proc shrink-proc extract-proc clear-proc+props))
c/i-hash-set-hash-set-proc
c/i-hash-set-hash-remove-proc
c/i-hash-set-hash-key-proc
c/i-hash-set-hash-clear-proc)
(define rewrap
(and (custom-set-spec s)
(custom-spec-wrap (custom-set-spec s))))
(update-custom-set-table
s
(if (custom-set-spec s)
(chaperone-or-impersonate-hash
(custom-set-table s)
(λ (hash key)
(define-values (a b)
(c/i-hash-set-hash-ref-proc hash (custom-elem-contents key)))
(values (rewrap a) b))
(λ (hash key val)
(define-values (a b)
(c/i-hash-set-hash-set-proc hash (custom-elem-contents key) val))
(values (rewrap a) b))
(λ (hash key)
(rewrap (c/i-hash-set-hash-remove-proc hash (custom-elem-contents key))))
(λ (hash key)
(rewrap (c/i-hash-set-hash-key-proc hash (custom-elem-contents key))))
c/i-hash-set-hash-clear-proc)
(chaperone-or-impersonate-hash
(custom-set-table s)
c/i-hash-set-hash-ref-proc
c/i-hash-set-hash-set-proc
c/i-hash-set-hash-remove-proc
c/i-hash-set-hash-key-proc
c/i-hash-set-hash-clear-proc))))
(define (impersonate-hash-set s
ref-proc
add-proc
remove-proc
.
clear-proc+props)
(define-values (clear-proc prop-args)
(check-chap/imp-args #t
s
ref-proc
add-proc
remove-proc
clear-proc+props))
(define impersonate-hash-set-hash-ref-proc
(λ (hash key) (values (ref-proc (update-custom-set-table s hash) key)
(λ (hash key val) val))))
(define impersonate-hash-set-hash-set-proc
(λ (hash key val) (values (add-proc (update-custom-set-table s hash) key) val)))
(define impersonate-hash-set-hash-remove-proc
(λ (hash key) (remove-proc (update-custom-set-table s hash) key)))
(define impersonate-hash-set-hash-key-proc
(λ (hash key) (ref-proc (update-custom-set-table s hash) key)))
(define impersonate-hash-set-hash-clear-proc
(and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))
(define rewrap
(and (custom-set-spec s)
(custom-spec-wrap (custom-set-spec s))))
(add-impersonator-properties (add-impersonator-properties
(if ref-proc (if inject-proc
(chap-or-imp-hash-set s (chap-or-imp-hash-set s
impersonate-hash impersonate-hash
impersonate-hash-set-hash-ref-proc (λ (ele) (inject-proc s ele))
impersonate-hash-set-hash-set-proc (λ (ele) (add-proc s ele))
impersonate-hash-set-hash-remove-proc (λ (ele) (shrink-proc s ele))
impersonate-hash-set-hash-key-proc (λ (ele) (extract-proc s ele))
impersonate-hash-set-hash-clear-proc) (and clear-proc (λ () (clear-proc s)))
(λ (ele) (equal-key-proc s ele)))
s) s)
prop-args)) prop-args))
(define (chap-or-imp-hash-set s c-or-i-hash
inject-proc add-proc shrink-proc extract-proc
clear-proc equal-key-proc)
(update-custom-set-table
s
(cond
[(custom-set-spec s)
(define rewrap (custom-spec-wrap (custom-set-spec s)))
(c-or-i-hash
(custom-set-table s)
(λ (hash key) (values (rewrap (inject-proc (custom-elem-contents key)))
(λ (hash key val) val)))
(λ (hash key val) (values (rewrap (add-proc (custom-elem-contents key))) val))
(λ (hash key) (rewrap (shrink-proc (custom-elem-contents key))))
(λ (hash key) (rewrap (extract-proc (custom-elem-contents key))))
(λ (hash) (clear-proc))
(λ (hash key) (rewrap (equal-key-proc (custom-elem-contents key)))))]
[else
(c-or-i-hash
(custom-set-table s)
(λ (hash key) (values (inject-proc key) (λ (hash key val) val)))
(λ (hash key val) (values (add-proc key) val))
(λ (hash key) (shrink-proc key))
(λ (hash key) (extract-proc key))
(λ (hash) (clear-proc))
(λ (hash key) (equal-key-proc key)))])))
(define (add-impersonator-properties without-props prop-args) (define (add-impersonator-properties without-props prop-args)
(cond (cond
[(null? prop-args) without-props] [(null? prop-args) without-props]
@ -467,12 +414,9 @@
[else [else
(apply chaperone-struct without-props struct:mutable-custom-set prop-args)])) (apply chaperone-struct without-props struct:mutable-custom-set prop-args)]))
(define (check-chap/imp-args impersonate? (define (check-chap/imp-args impersonate? s
s inject-proc add-proc shrink-proc extract-proc
ref-proc clear-proc+equal-key-proc+props)
add-proc
remove-proc
clear-proc+props)
(define who (if impersonate? 'impersonate-hash-set 'chaperone-hash-set)) (define who (if impersonate? 'impersonate-hash-set 'chaperone-hash-set))
(unless (if impersonate? (unless (if impersonate?
(or (set-mutable? s) (set-weak? s)) (or (set-mutable? s) (set-weak? s))
@ -483,55 +427,69 @@
(if impersonate? (if impersonate?
'(or/c set-mutable? set-weak?) '(or/c set-mutable? set-weak?)
'(or/c set? set-mutable? set-weak?))) '(or/c set? set-mutable? set-weak?)))
0 s ref-proc add-proc clear-proc+props)) 0 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
(unless (or (not ref-proc) (unless (or (not inject-proc)
(and (procedure? ref-proc) (and (procedure? inject-proc)
(procedure-arity-includes? ref-proc 2))) (procedure-arity-includes? inject-proc 2)))
(apply raise-argument-error (apply raise-argument-error
who who
"(or/c #f (procedure-arity-includes/c 2))" "(or/c #f (procedure-arity-includes/c 2))"
1 s ref-proc add-proc clear-proc+props)) 1 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
(unless (or (not add-proc) (unless (or (not add-proc)
(and (procedure? add-proc) (and (procedure? add-proc)
(procedure-arity-includes? add-proc 2))) (procedure-arity-includes? add-proc 2)))
(apply raise-argument-error (apply raise-argument-error
who who
"(or/c #f (procedure-arity-includes/c 2))" "(or/c #f (procedure-arity-includes/c 2))"
2 s ref-proc add-proc clear-proc+props)) 2 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
(unless (or (not remove-proc) (unless (or (not shrink-proc)
(and (procedure? remove-proc) (and (procedure? shrink-proc)
(procedure-arity-includes? remove-proc 2))) (procedure-arity-includes? shrink-proc 2)))
(apply raise-argument-error (apply raise-argument-error
who who
"(or/c #f (procedure-arity-includes/c 2))" "(or/c #f (procedure-arity-includes/c 2))"
3 s ref-proc add-proc clear-proc+props)) 3 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
(when (or (not ref-proc) (not add-proc) (not remove-proc)) (unless (or (not extract-proc)
(unless (and (not ref-proc) (not add-proc) (not remove-proc)) (and (procedure? extract-proc)
(raise-arguments-error who (procedure-arity-includes? extract-proc 2)))
"if one of ref-proc, add-proc, or remove-proc is #f, they must all be" (apply raise-argument-error
"ref-proc" ref-proc who
"add-proc" add-proc "(or/c #f (procedure-arity-includes/c 2))"
"remove-proc" remove-proc))) 4 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
(unless (null? clear-proc+props) (unless (null? clear-proc+equal-key-proc+props)
(unless (or (not (car clear-proc+props)) (unless (or (not (car clear-proc+equal-key-proc+props))
(and (procedure? (car clear-proc+props)) (and (procedure? (car clear-proc+equal-key-proc+props))
(procedure-arity-includes? (car clear-proc+props) 1)) (procedure-arity-includes? (car clear-proc+equal-key-proc+props) 1))
(impersonator-property? (car clear-proc+props))) (impersonator-property? (car clear-proc+equal-key-proc+props)))
(apply raise-argument-error (apply raise-argument-error
who who
(format "~s" `(or/c #f (format "~s" `(or/c #f
(procedure-arity-includes/c 1) (procedure-arity-includes/c 1)
impersonator-property?)) impersonator-property?))
4 5
s ref-proc add-proc clear-proc+props))) s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)))
(define-values (supplied-clear-proc? clear-proc args) (define-values (num-supplied-procs clear-proc equal-key-proc args)
(cond (cond
[(null? clear-proc+props) (values #f #f '())] [(null? clear-proc+equal-key-proc+props) (values 0 #f #f '())]
[(impersonator-property? (car clear-proc+props)) (values #f #f clear-proc+props)] [(impersonator-property? (car clear-proc+equal-key-proc+props))
(values 0 #f #f clear-proc+equal-key-proc+props)]
[else [else
(values #t (define clear-proc (car clear-proc+equal-key-proc+props))
(car clear-proc+props) (define equal-key-proc+props (cdr clear-proc+equal-key-proc+props))
(cdr clear-proc+props))])) (cond
[(null? equal-key-proc+props) (values 1 clear-proc #f '())]
[(impersonator-property? (car equal-key-proc+props))
(values 1 clear-proc #f equal-key-proc+props)]
[else
(values 2 clear-proc (car equal-key-proc+props) (cdr equal-key-proc+props))])]))
(unless (or (not equal-key-proc)
(and (procedure? equal-key-proc)
(procedure-arity-includes? equal-key-proc 2)))
(apply raise-argument-error
who
"(or/c #f (procedure-arity-includes/c 1))"
(+ 4 num-supplied-procs)
s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
(for ([ele (in-list args)] (for ([ele (in-list args)]
[i (in-naturals)] [i (in-naturals)]
#:when (even? i)) #:when (even? i))
@ -539,14 +497,31 @@
(apply raise-argument-error (apply raise-argument-error
who who
"impersonator-property?" "impersonator-property?"
(+ i (if supplied-clear-proc? 1 0) 4) (+ i num-supplied-procs 4)
s ref-proc add-proc clear-proc+props))) s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)))
(unless ref-proc (when (or (not inject-proc) (not add-proc) (not shrink-proc) (not extract-proc))
(unless (and (not inject-proc) (not add-proc) (not shrink-proc) (not extract-proc)
(not equal-key-proc) (not clear-proc))
(raise-arguments-error who
(string-append
"if one of inject-proc, add-proc, shrink-proc"
" or extract-proc is #f, they must all be and the"
" equal-key-proc and clear-proc must also be")
"inject-proc" inject-proc
"add-proc" add-proc
"shrink-proc" shrink-proc
"extract-proc" extract-proc
"equal-key-proc" equal-key-proc
"clear-proc" clear-proc)))
(unless inject-proc
(when (null? args) (when (null? args)
(raise-arguments-error (raise-arguments-error
who who
"when ref-proc, add-proc, and remove-proc are #f, at least one property must be supplied"))) "when inject-proc, add-proc, shrink-proc, and extract-proc are #f,"
(values clear-proc args)) " at least one property must be supplied")))
(values clear-proc
(or equal-key-proc (λ (s e) e))
args))
(define (set-check-compatible name s1 s2) (define (set-check-compatible name s1 s2)
(define spec (custom-set-spec s1)) (define spec (custom-set-spec s1))

62
racket/collects/racket/set.rkt
View File

@ -50,10 +50,13 @@
set/c) set/c)
(define/subexpression-pos-prop/name (define/subexpression-pos-prop/name
real-set/c-name (set/c elem/c real-set/c-name (set/c _elem/c
#:equal-key/c [_equal-key/c any/c]
#:cmp [cmp 'dont-care] #:cmp [cmp 'dont-care]
#:kind [kind 'immutable] #:kind [kind 'immutable]
#:lazy? [_lazy? (lazy-default kind elem/c)]) #:lazy? [_lazy? (lazy-default kind _elem/c)])
(define elem/c (coerce-contract 'set/c _elem/c))
(define equal-key/c (coerce-contract 'set/c _equal-key/c))
(define lazy? (and _lazy? #t)) (define lazy? (and _lazy? #t))
(define cmp/c (define cmp/c
(case cmp (case cmp
@ -80,7 +83,7 @@
(raise-arguments-error (raise-arguments-error
'set/c 'set/c
"element contract must be a flat contract for eqv? and eq?-based sets" "element contract must be a flat contract for eqv? and eq?-based sets"
"element contract" (contract-name elem/c) "element contract" elem/c
"#:cmp option" cmp))] "#:cmp option" cmp))]
[else [else
(unless (chaperone-contract? elem/c) (unless (chaperone-contract? elem/c)
@ -88,14 +91,15 @@
(cond (cond
[(and (eq? kind 'immutable) [(and (eq? kind 'immutable)
(not lazy?) (not lazy?)
(flat-contract? elem/c)) (flat-contract? elem/c)
(flat-set-contract elem/c cmp kind lazy?)] (flat-contract? equal-key/c))
(flat-set-contract elem/c equal-key/c cmp kind lazy?)]
[(chaperone-contract? elem/c) [(chaperone-contract? elem/c)
(chaperone-set-contract elem/c cmp kind lazy?)] (chaperone-set-contract elem/c equal-key/c cmp kind lazy?)]
[else [else
(impersonator-set-contract elem/c cmp kind lazy?)])) (impersonator-set-contract elem/c equal-key/c cmp kind lazy?)]))
(struct set-contract [elem/c cmp kind lazy?]) (struct set-contract [elem/c equal-key/c cmp kind lazy?])
(define (lazy-default kind elem/c) (define (lazy-default kind elem/c)
(not (and (equal? kind 'immutable) (not (and (equal? kind 'immutable)
@ -177,25 +181,45 @@
(define (hash-set-late-neg-projection ctc chaperone-ctc?) (define (hash-set-late-neg-projection ctc chaperone-ctc?)
(define elem/c (set-contract-elem/c ctc)) (define elem/c (set-contract-elem/c ctc))
(define equal-key/c (set-contract-equal-key/c ctc))
(define cmp (set-contract-cmp ctc)) (define cmp (set-contract-cmp ctc))
(define kind (set-contract-kind ctc)) (define kind (set-contract-kind ctc))
(define late-neg-ele-proj (contract-late-neg-projection elem/c)) (define late-neg-ele-proj (contract-late-neg-projection elem/c))
(define late-neg-equal-key-proj (contract-late-neg-projection equal-key/c))
(define lazy? (set-contract-lazy? ctc)) (define lazy? (set-contract-lazy? ctc))
(λ (blame) (λ (blame)
(define ele-neg-blame (blame-add-element-context blame #t))
(define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f))) (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 late-neg-neg-proj (late-neg-ele-proj ele-neg-blame))
(define late-neg-equal-key-pos-proj (late-neg-equal-key-proj ele-neg-blame))
(cond (cond
[lazy? [lazy?
(λ (val neg-party) (λ (val neg-party)
(set-contract-check cmp kind blame neg-party val) (set-contract-check cmp kind blame neg-party val)
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party)) (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
(cond
[(set? val)
(chaperone-hash-set (chaperone-hash-set
val val
pos-interpose (λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party)) (λ (val ele) ele)
pos-interpose (λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party))
(λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party)))] impersonator-prop:blame (cons blame neg-party))]
[else
(chaperone-hash-set
val
(λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party))
(λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party))
(λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party))
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))]
[else [else
(λ (val neg-party) (λ (val neg-party)
(set-contract-check cmp kind blame neg-party val) (set-contract-check cmp kind blame neg-party val)
@ -209,15 +233,17 @@
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))] impersonator-prop:blame (cons blame neg-party))]
[else [else
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
(for ([ele (in-list (set->list val))]) (for ([ele (in-list (set->list val))])
(set-remove! val ele) (set-remove! val ele)
(set-add! val (late-neg-pos-proj ele neg-party))) (set-add! val (late-neg-pos-proj ele neg-party)))
(chaperone-hash-set (chaperone-hash-set
val val
pos-interpose (λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party)) (λ (val ele) (late-neg-neg-proj ele neg-party))
pos-interpose (λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party))
(λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))]))) impersonator-prop:blame (cons blame neg-party))]))])))
@ -313,6 +339,10 @@
(for/and ([e (in-set x)]) (for/and ([e (in-set x)])
(elem-passes? e))))) (elem-passes? e)))))
;; since the equal-key/c must be a flat contract
;; in order for the entire set/c to be a flat contract,
;; then we know that it doesn't have any negative blame
;; and thus can never fail; so this projection ignores it.
(define (flat-set-contract-late-neg-projection ctc) (define (flat-set-contract-late-neg-projection ctc)
(define elem/c (set-contract-elem/c ctc)) (define elem/c (set-contract-elem/c ctc))
(define cmp (set-contract-cmp ctc)) (define cmp (set-contract-cmp ctc))