Clean up chaperone-hash-set and impersonate-hash-set and adjust set/c to match
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
parent
77a76a7953
commit
1c431e6f4d
|
|
@ -2384,10 +2384,17 @@ is expected to be the contract on the value).
|
|||
@defthing[impersonator-prop:blame impersonator-property?]
|
||||
)]{
|
||||
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
|
||||
@racket[blame-contract] extracts the value from the property (which
|
||||
is expected to be the blame record for the contract on the value).
|
||||
@racket[value-blame] extracts the value from the property.
|
||||
|
||||
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[(
|
||||
|
|
|
|||
|
|
@ -206,7 +206,8 @@ named by the @racket[sym]s.
|
|||
'immutable]
|
||||
[#:lazy? lazy? any/c
|
||||
(not (and (equal? kind 'immutable)
|
||||
(flat-contract? elem/c)))])
|
||||
(flat-contract? elem/c)))]
|
||||
[#:equal-key/c equal-key/c contract? any/c])
|
||||
contract?]{
|
||||
|
||||
Constructs a contract that recognizes sets whose elements match
|
||||
|
|
@ -243,9 +244,13 @@ named by the @racket[sym]s.
|
|||
@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 @racket[equal-key/c] contract is used when values are passed to the comparison
|
||||
and hashing functions used internally.
|
||||
|
||||
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 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
|
||||
@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?]
|
||||
[ref-proc (or/c #f (-> set? any/c any/c))]
|
||||
@defproc[(impersonate-hash-set [st (or/c mutable-set? weak-set?)]
|
||||
[inject-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]
|
||||
[equal-key-proc (or/c #f (-> set? any/c any/c)) #f]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any/c] ... ...)
|
||||
(and/c set? impersonator?)]{
|
||||
Impersonates @racket[st], redirecting via the given procedures.
|
||||
(and/c (or/c mutable-set? weak-set?) impersonator?)]{
|
||||
Impersonates @racket[st], redirecting various set operations 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[inject-proc] procedure
|
||||
is called whenever an element is temporarily put into the set for the purposes
|
||||
of comparing it with other elements that may already be in the set. For example,
|
||||
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].
|
||||
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[add-proc] procedure is called when adding an element to a set, e.g.,
|
||||
via @racket[set-add] or @racket[set-add!]. The result of the @racket[add-proc] is
|
||||
stored in 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 any of the @racket[ref-proc], @racket[add-proc], or @racket[remove-proc] arguments
|
||||
is @racket[#f], then all three must be and there must be at least one property supplied.
|
||||
In that case, a more efficient chaperone wrapper is created.
|
||||
The @racket[shrink-proc] procedure is called when building a new set with
|
||||
one fewer element. For example, when evaluating @racket[(set-remove s e)]
|
||||
or @racket[(set-remove! s e)],
|
||||
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 @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!].
|
||||
The @racket[extract-proc] procedure is called when an element is pulled out of
|
||||
a set, e.g., by @racket[set-first]. The result of the @racket[extract-proc] is
|
||||
the element actually produced by from the set.
|
||||
|
||||
The @racket[clear-proc] is called by @racket[set-clear] and @racket[set-clear!]
|
||||
and if it returns (as opposed to escaping, perhaps via raising an exception),
|
||||
the clearing operation is permitted. Its result is ignored. If @racket[clear-proc]
|
||||
is @racket[#f], then clearing is done element by element (via calls into the other
|
||||
supplied procedures).
|
||||
|
||||
The @racket[equal-key-proc] is called when an element's hash code is needed of when an
|
||||
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
|
||||
@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 (or/c #f (-> set? any/c any/c))]
|
||||
@defproc[(chaperone-hash-set [st (or/c set? mutable-set? weak-set?)]
|
||||
[inject-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]
|
||||
[equal-key-proc (or/c #f (-> set? any/c any/c)) #f]
|
||||
[prop impersonator-property?]
|
||||
[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
|
||||
the constraints that the results of the @racket[ref-proc],
|
||||
@racket[add-proc], and @racket[remove-proc] must be
|
||||
the constraints that the results of the @racket[inject-proc],
|
||||
@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
|
||||
may be an @racket[immutable?] set.
|
||||
}
|
||||
|
|
|
|||
|
|
@ -561,153 +561,223 @@
|
|||
(add1 i)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; set/c tests
|
||||
;; chaperone-hash-set tests
|
||||
|
||||
(err/rt-test (set/c '(not a contract)))
|
||||
(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))
|
||||
(let ()
|
||||
|
||||
;; adds a tracing chaperone to 's', runs 'go' on it, and returns the trace
|
||||
(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))
|
||||
|
||||
(test '((extract 1))
|
||||
counting-chaperone
|
||||
(set 1)
|
||||
(λ (s) (set-first s))
|
||||
#f)
|
||||
(test '((add 1))
|
||||
counting-chaperone
|
||||
(set)
|
||||
(λ (s) (set-add s 1))
|
||||
#f)
|
||||
(test '((extract 1))
|
||||
counting-chaperone
|
||||
(mutable-set 1)
|
||||
(λ (s) (set-first s))
|
||||
#f)
|
||||
(test '((extract 1))
|
||||
counting-chaperone
|
||||
(weak-set 1)
|
||||
(λ (s) (set-first s))
|
||||
#f)
|
||||
(test '((add 2))
|
||||
counting-chaperone
|
||||
(mutable-set 1)
|
||||
(λ (s) (set-add! s 2))
|
||||
#f)
|
||||
(test '((inject 2))
|
||||
counting-chaperone
|
||||
(mutable-set 1)
|
||||
(λ (s) (set-member? s 2))
|
||||
#f)
|
||||
(test '((inject 1))
|
||||
counting-chaperone
|
||||
(mutable-set 1)
|
||||
(λ (s) (set-member? s 1))
|
||||
#f)
|
||||
(test '((shrink 1))
|
||||
counting-chaperone
|
||||
(set 1)
|
||||
(λ (s) (set-remove s 1))
|
||||
#f)
|
||||
(test '((shrink 1))
|
||||
counting-chaperone
|
||||
(mutable-set 1)
|
||||
(λ (s) (set-remove! s 1))
|
||||
#f)
|
||||
(test '((inject 2) (equal-key 2) (equal-key 2))
|
||||
counting-chaperone
|
||||
(set 2)
|
||||
(λ (s) (set-member? s 2))
|
||||
#t)
|
||||
(test '((extract 0))
|
||||
counting-chaperone
|
||||
(let ()
|
||||
(define-custom-set-types set2 equal? equal-hash-code)
|
||||
(define ele #f)
|
||||
(set-add (make-immutable-set2) 0))
|
||||
(λ (s) (set-first s))
|
||||
#f)
|
||||
(test '((extract 0))
|
||||
counting-chaperone
|
||||
(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))
|
||||
|
||||
(define (app-ctc ctc value)
|
||||
(contract ctc value 'positive 'negative))
|
||||
|
||||
(define (positive-error? exn)
|
||||
(and exn:fail:contract?
|
||||
(regexp-match? "blaming: positive" (exn-message exn))))
|
||||
(define (negative-error? exn)
|
||||
(and exn:fail:contract?
|
||||
(regexp-match? "blaming: negative" (exn-message exn))))
|
||||
|
||||
(define-syntax-rule (test/blame-pos e)
|
||||
(thunk-error-test (lambda () e) #'e positive-error?))
|
||||
(define-syntax-rule (test/blame-neg e)
|
||||
(thunk-error-test (lambda () e) #'e negative-error?))
|
||||
|
||||
;; check dont-care defaults
|
||||
(test #t set? (app-ctc (set/c any/c) (set)))
|
||||
(test #t set? (app-ctc (set/c any/c) (seteq)))
|
||||
|
||||
(test/blame-pos (app-ctc (set/c any/c) (mutable-set))) ; check immutable default
|
||||
(test/blame-pos (app-ctc (set/c any/c #:cmp 'eq) (set)))
|
||||
(test/blame-pos (app-ctc (set/c any/c #:kind 'mutable) (set)))
|
||||
(test/blame-pos (app-ctc (set/c string? #:kind 'immutable) (set 1)))
|
||||
(test/blame-pos (app-ctc (set/c string?) (set 1)))
|
||||
(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))))
|
||||
(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 ()
|
||||
(define-custom-set-types set2 equal? equal-hash-code)
|
||||
(set-first
|
||||
(set-add (chaperone-hash-set
|
||||
(make-immutable-set2)
|
||||
(λ (a b) b)
|
||||
(λ (a b) b)
|
||||
(λ (a b) b))
|
||||
0))))
|
||||
(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)
|
||||
(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)
|
||||
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 (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)
|
||||
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)
|
||||
(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)))
|
||||
|
||||
(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p)
|
||||
(make-impersonator-property 'p)])
|
||||
(let ([s (impersonate-hash-set (mutable-set) (λ (s l) l) (λ (s l) l) (λ (s l) l)
|
||||
(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 impersonator-prop:p 11)])
|
||||
(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 impersonator-prop:p 11)])
|
||||
(let ([s (impersonate-hash-set (mutable-set) #f #f #f #f impersonator-prop:p 11)])
|
||||
(test 11 get-impersonator-prop:p s)))
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,59 @@
|
|||
|
||||
(parameterize ([current-contract-namespace
|
||||
(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
|
||||
'set/c1
|
||||
|
|
@ -236,7 +289,7 @@
|
|||
add1)))
|
||||
|
||||
(test/spec-passed
|
||||
'set/c30
|
||||
'set/c31
|
||||
'(let ()
|
||||
(define-custom-set-types set2 equal?)
|
||||
(set-add
|
||||
|
|
@ -244,5 +297,25 @@
|
|||
(make-immutable-set2)
|
||||
'pos 'neg)
|
||||
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))))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -163,7 +163,7 @@
|
|||
name
|
||||
(contract-eval #:test-case-name name
|
||||
`(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)))))
|
||||
|
||||
;; test/spec-passed : symbol sexp -> void
|
||||
|
|
@ -281,7 +281,7 @@
|
|||
(define (good-thing? l)
|
||||
(for/or ([x (in-list l)])
|
||||
(and (symbol? x)
|
||||
(regexp-match #rx"contract" (symbol->string x)))))
|
||||
(regexp-match? #rx"contract" (symbol->string x)))))
|
||||
(cond
|
||||
[(and (pair? body)
|
||||
(eq? (car body) 'require)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
(require "test-util.rkt")
|
||||
|
||||
(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 (λ (x) x))
|
||||
|
|
@ -50,7 +51,7 @@
|
|||
'(let ()
|
||||
(define c (-> integer? integer?))
|
||||
(define f (contract c (λ (x) x) 'pos 'neg))
|
||||
;; opt/c version doesn't yet have blame, so
|
||||
;; 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-contract? f)
|
||||
(equal? c (value-contract f)))
|
||||
|
|
@ -58,13 +59,49 @@
|
|||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'value-blame
|
||||
'value-blame.1
|
||||
'(let ()
|
||||
(define f
|
||||
(contract (-> integer? integer?) (λ (x) x) 'pos 'neg))
|
||||
;; opt/c version doesn't yet have blame, so
|
||||
;; 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.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)
|
||||
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -139,11 +139,17 @@
|
|||
(has-impersonator-prop:blame? v)))
|
||||
|
||||
(define (value-blame v)
|
||||
(define bv
|
||||
(cond
|
||||
[(has-prop:blame? v)
|
||||
(get-prop:blame v)]
|
||||
[(has-impersonator-prop:blame? v)
|
||||
(get-impersonator-prop:blame v)]
|
||||
[else #f]))
|
||||
(cond
|
||||
[(has-prop:blame? v)
|
||||
(get-prop:blame v)]
|
||||
[(has-impersonator-prop:blame? v)
|
||||
(get-impersonator-prop:blame v)]
|
||||
[(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)
|
||||
|
|
|
|||
|
|
@ -338,19 +338,9 @@
|
|||
[(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 prop-args)
|
||||
(check-chap/imp-args #f
|
||||
s
|
||||
ref-proc
|
||||
add-proc
|
||||
remove-proc
|
||||
clear-proc+props))
|
||||
(define (chaperone-hash-set s inject-proc add-proc shrink-proc extract-proc . clear-proc+props)
|
||||
(define-values (clear-proc equal-key-proc prop-args)
|
||||
(check-chap/imp-args #f s inject-proc add-proc shrink-proc extract-proc clear-proc+props))
|
||||
(define (check-it who original new)
|
||||
(unless (chaperone-of? new original)
|
||||
(error 'chaperone-hash-set
|
||||
|
|
@ -358,105 +348,62 @@
|
|||
who original 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
|
||||
(if ref-proc
|
||||
(if inject-proc
|
||||
(chap-or-imp-hash-set s
|
||||
chaperone-hash
|
||||
chaperone-hash-set-hash-ref-proc
|
||||
chaperone-hash-set-hash-set-proc
|
||||
chaperone-hash-set-hash-remove-proc
|
||||
chaperone-hash-set-hash-key-proc
|
||||
chaperone-hash-set-hash-clear-proc)
|
||||
(λ (ele) (check-it 'in-proc ele (inject-proc s ele)))
|
||||
(λ (ele) (check-it 'add-proc ele (add-proc s ele)))
|
||||
(λ (ele) (check-it 'shrink-proc ele (shrink-proc s ele)))
|
||||
(λ (ele) (check-it 'extract-proc ele (extract-proc s ele)))
|
||||
(and clear-proc (λ () (clear-proc s)))
|
||||
(λ (ele) (equal-key-proc s ele)))
|
||||
s)
|
||||
prop-args))
|
||||
|
||||
(define (chap-or-imp-hash-set s
|
||||
chaperone-or-impersonate-hash
|
||||
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 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))))
|
||||
(define (impersonate-hash-set s inject-proc add-proc shrink-proc extract-proc . clear-proc+props)
|
||||
(define-values (clear-proc equal-key-proc prop-args)
|
||||
(check-chap/imp-args #t s inject-proc add-proc shrink-proc extract-proc clear-proc+props))
|
||||
(add-impersonator-properties
|
||||
(if ref-proc
|
||||
(if inject-proc
|
||||
(chap-or-imp-hash-set s
|
||||
impersonate-hash
|
||||
impersonate-hash-set-hash-ref-proc
|
||||
impersonate-hash-set-hash-set-proc
|
||||
impersonate-hash-set-hash-remove-proc
|
||||
impersonate-hash-set-hash-key-proc
|
||||
impersonate-hash-set-hash-clear-proc)
|
||||
(λ (ele) (inject-proc s ele))
|
||||
(λ (ele) (add-proc s ele))
|
||||
(λ (ele) (shrink-proc s ele))
|
||||
(λ (ele) (extract-proc s ele))
|
||||
(and clear-proc (λ () (clear-proc s)))
|
||||
(λ (ele) (equal-key-proc s ele)))
|
||||
s)
|
||||
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)
|
||||
(cond
|
||||
[(null? prop-args) without-props]
|
||||
|
|
@ -467,12 +414,9 @@
|
|||
[else
|
||||
(apply chaperone-struct without-props struct:mutable-custom-set prop-args)]))
|
||||
|
||||
(define (check-chap/imp-args impersonate?
|
||||
s
|
||||
ref-proc
|
||||
add-proc
|
||||
remove-proc
|
||||
clear-proc+props)
|
||||
(define (check-chap/imp-args impersonate? s
|
||||
inject-proc add-proc shrink-proc extract-proc
|
||||
clear-proc+equal-key-proc+props)
|
||||
(define who (if impersonate? 'impersonate-hash-set 'chaperone-hash-set))
|
||||
(unless (if impersonate?
|
||||
(or (set-mutable? s) (set-weak? s))
|
||||
|
|
@ -483,55 +427,69 @@
|
|||
(if impersonate?
|
||||
'(or/c set-mutable? set-weak?)
|
||||
'(or/c set? set-mutable? set-weak?)))
|
||||
0 s ref-proc add-proc clear-proc+props))
|
||||
(unless (or (not ref-proc)
|
||||
(and (procedure? ref-proc)
|
||||
(procedure-arity-includes? ref-proc 2)))
|
||||
0 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
|
||||
(unless (or (not inject-proc)
|
||||
(and (procedure? inject-proc)
|
||||
(procedure-arity-includes? inject-proc 2)))
|
||||
(apply raise-argument-error
|
||||
who
|
||||
"(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)
|
||||
(and (procedure? add-proc)
|
||||
(procedure-arity-includes? add-proc 2)))
|
||||
(apply raise-argument-error
|
||||
who
|
||||
"(or/c #f (procedure-arity-includes/c 2))"
|
||||
2 s ref-proc add-proc clear-proc+props))
|
||||
(unless (or (not remove-proc)
|
||||
(and (procedure? remove-proc)
|
||||
(procedure-arity-includes? remove-proc 2)))
|
||||
2 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
|
||||
(unless (or (not shrink-proc)
|
||||
(and (procedure? shrink-proc)
|
||||
(procedure-arity-includes? shrink-proc 2)))
|
||||
(apply raise-argument-error
|
||||
who
|
||||
"(or/c #f (procedure-arity-includes/c 2))"
|
||||
3 s ref-proc add-proc clear-proc+props))
|
||||
(when (or (not ref-proc) (not add-proc) (not remove-proc))
|
||||
(unless (and (not ref-proc) (not add-proc) (not remove-proc))
|
||||
(raise-arguments-error who
|
||||
"if one of ref-proc, add-proc, or remove-proc is #f, they must all be"
|
||||
"ref-proc" ref-proc
|
||||
"add-proc" add-proc
|
||||
"remove-proc" remove-proc)))
|
||||
(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)))
|
||||
3 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
|
||||
(unless (or (not extract-proc)
|
||||
(and (procedure? extract-proc)
|
||||
(procedure-arity-includes? extract-proc 2)))
|
||||
(apply raise-argument-error
|
||||
who
|
||||
"(or/c #f (procedure-arity-includes/c 2))"
|
||||
4 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))
|
||||
(unless (null? clear-proc+equal-key-proc+props)
|
||||
(unless (or (not (car clear-proc+equal-key-proc+props))
|
||||
(and (procedure? (car clear-proc+equal-key-proc+props))
|
||||
(procedure-arity-includes? (car clear-proc+equal-key-proc+props) 1))
|
||||
(impersonator-property? (car clear-proc+equal-key-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)
|
||||
5
|
||||
s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)))
|
||||
(define-values (num-supplied-procs clear-proc equal-key-proc args)
|
||||
(cond
|
||||
[(null? clear-proc+props) (values #f #f '())]
|
||||
[(impersonator-property? (car clear-proc+props)) (values #f #f clear-proc+props)]
|
||||
[(null? clear-proc+equal-key-proc+props) (values 0 #f #f '())]
|
||||
[(impersonator-property? (car clear-proc+equal-key-proc+props))
|
||||
(values 0 #f #f clear-proc+equal-key-proc+props)]
|
||||
[else
|
||||
(values #t
|
||||
(car clear-proc+props)
|
||||
(cdr clear-proc+props))]))
|
||||
(define clear-proc (car clear-proc+equal-key-proc+props))
|
||||
(define equal-key-proc+props (cdr clear-proc+equal-key-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)]
|
||||
[i (in-naturals)]
|
||||
#:when (even? i))
|
||||
|
|
@ -539,14 +497,31 @@
|
|||
(apply raise-argument-error
|
||||
who
|
||||
"impersonator-property?"
|
||||
(+ i (if supplied-clear-proc? 1 0) 4)
|
||||
s ref-proc add-proc clear-proc+props)))
|
||||
(unless ref-proc
|
||||
(+ i num-supplied-procs 4)
|
||||
s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)))
|
||||
(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)
|
||||
(raise-arguments-error
|
||||
who
|
||||
"when ref-proc, add-proc, and remove-proc are #f, at least one property must be supplied")))
|
||||
(values clear-proc args))
|
||||
"when inject-proc, add-proc, shrink-proc, and extract-proc are #f,"
|
||||
" 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 spec (custom-set-spec s1))
|
||||
|
|
|
|||
|
|
@ -50,10 +50,13 @@
|
|||
set/c)
|
||||
|
||||
(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]
|
||||
#: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 cmp/c
|
||||
(case cmp
|
||||
|
|
@ -80,7 +83,7 @@
|
|||
(raise-arguments-error
|
||||
'set/c
|
||||
"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))]
|
||||
[else
|
||||
(unless (chaperone-contract? elem/c)
|
||||
|
|
@ -88,14 +91,15 @@
|
|||
(cond
|
||||
[(and (eq? kind 'immutable)
|
||||
(not lazy?)
|
||||
(flat-contract? elem/c))
|
||||
(flat-set-contract elem/c cmp kind lazy?)]
|
||||
(flat-contract? elem/c)
|
||||
(flat-contract? equal-key/c))
|
||||
(flat-set-contract elem/c equal-key/c cmp kind lazy?)]
|
||||
[(chaperone-contract? elem/c)
|
||||
(chaperone-set-contract elem/c cmp kind lazy?)]
|
||||
(chaperone-set-contract elem/c equal-key/c cmp kind lazy?)]
|
||||
[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)
|
||||
(not (and (equal? kind 'immutable)
|
||||
|
|
@ -177,25 +181,45 @@
|
|||
|
||||
(define (hash-set-late-neg-projection ctc chaperone-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 kind (set-contract-kind ctc))
|
||||
(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))
|
||||
(λ (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-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
|
||||
[lazy?
|
||||
(λ (val neg-party)
|
||||
(set-contract-check cmp kind blame neg-party val)
|
||||
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
|
||||
(chaperone-hash-set
|
||||
val
|
||||
pos-interpose
|
||||
(λ (val ele) (late-neg-neg-proj ele neg-party))
|
||||
pos-interpose
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (cons blame 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
|
||||
(λ (val ele) ele)
|
||||
(λ (val ele) ele)
|
||||
(λ (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
|
||||
(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
|
||||
(λ (val neg-party)
|
||||
(set-contract-check cmp kind blame neg-party val)
|
||||
|
|
@ -209,15 +233,17 @@
|
|||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (cons blame neg-party))]
|
||||
[else
|
||||
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
|
||||
(for ([ele (in-list (set->list val))])
|
||||
(set-remove! val ele)
|
||||
(set-add! val (late-neg-pos-proj ele neg-party)))
|
||||
(chaperone-hash-set
|
||||
val
|
||||
pos-interpose
|
||||
(λ (val ele) ele)
|
||||
(λ (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:blame (cons blame neg-party))]))])))
|
||||
|
||||
|
|
@ -313,6 +339,10 @@
|
|||
(for/and ([e (in-set x)])
|
||||
(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 elem/c (set-contract-elem/c ctc))
|
||||
(define cmp (set-contract-cmp ctc))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user