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

clean up interaction between strict set/c contracts and mutable sets

Browse Source
This commit is contained in:
Robby Findler 2015-12-29 20:28:22 -06:00
parent 757adac568
commit 46ace3172f
2 changed files with 65 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -166,12 +166,20 @@
(binary-set 5)
'pos 'neg)))
(test/spec-passed
(test/spec-passed/result
'set/c21
'(let* ([c (set/c (-> integer? integer?))]
[s (contract c (set (λ (x) x)) 'pos 'neg)])
(and (has-contract? s)
(equal? (value-contract s) c))))
(equal? (value-contract s) c)))
#t)
(test/spec-passed/result
'set/c2b
'(let* ([c (set/c (-> integer? integer?))]
[s (contract c (set (λ (x) x)) 'pos 'neg)])
(has-blame? s))
#t)
(test/spec-passed
'set/c22
@ -207,14 +215,34 @@
(test/neg-blame
'set/c28
'(let ([s (contract (set/c integer? #:lazy? #t)
(set #f) 'pos 'neg)])
'(let ([s (contract (set/c integer? #:lazy? #t #:kind 'dont-care)
(mutable-set #f) 'pos 'neg)])
(set-add! s "x")))
(test/neg-blame
'set/c29
'(let ([s (contract (set/c integer? #:lazy? #f)
(set 0) 'pos 'neg)])
'(let ([s (contract (set/c integer? #:lazy? #f #:kind 'mutable)
(mutable-set 0) 'pos 'neg)])
(set-add! s "x")))
(test/spec-passed
'set/c30
'(let ()
(define-custom-set-types set2 equal?)
(set-add
(contract (set/c (-> integer? integer?))
(make-immutable-set2)
'pos 'neg)
add1)))
(test/spec-passed
'set/c30
'(let ()
(define-custom-set-types set2 equal?)
(set-add
(contract (set/c (-> integer? integer?))
(make-immutable-set2)
'pos 'neg)
add1)))
)

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

@ -184,50 +184,42 @@
(λ (blame)
(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 set/c-lazy-late-neg-proj
(λ (val neg-party)
(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))
(cond
[(set? val)
(chaperone-hash-set
val
pos-interpose
(λ (val ele) ele)
pos-interpose
impersonator-prop:contracted
ctc)]
[else
(chaperone-hash-set
val
pos-interpose
(λ (val ele) (late-neg-neg-proj ele neg-party))
pos-interpose
impersonator-prop:contracted
ctc)])))
(cond
[lazy? set/c-lazy-late-neg-proj]
(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)))]
[else
(λ (val neg-party)
(set-contract-check cmp kind blame neg-party val)
(define w/chaperone
(cond
[(set? val) val]
[else
(chaperone-hash-set
val
(λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party))
(λ (val ele) ele))]))
(chaperone-hash-set
(for/set ([ele (in-set w/chaperone)])
(late-neg-pos-proj ele neg-party))
(chaperone-hash-set
val
#f #f #f
impersonator-prop:contracted
ctc)))])))
(cond
[(set? val)
(chaperone-hash-set
(for/fold ([s (set-clear val)])
([e (in-set val)])
(set-add s (late-neg-pos-proj e neg-party)))
#f #f #f
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) (late-neg-neg-proj ele neg-party))
pos-interpose
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))])))
(define (generic-set-late-neg-projection ctc chaperone-ctc?)
(define elem/c (set-contract-elem/c ctc))