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) (binary-set 5)
'pos 'neg))) 'pos 'neg)))
(test/spec-passed (test/spec-passed/result
'set/c21 'set/c21
'(let* ([c (set/c (-> integer? integer?))] '(let* ([c (set/c (-> integer? integer?))]
[s (contract c (set (λ (x) x)) 'pos 'neg)]) [s (contract c (set (λ (x) x)) 'pos 'neg)])
(and (has-contract? s) (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 (test/spec-passed
'set/c22 'set/c22
@ -207,14 +215,34 @@
(test/neg-blame (test/neg-blame
'set/c28 'set/c28
'(let ([s (contract (set/c integer? #:lazy? #t) '(let ([s (contract (set/c integer? #:lazy? #t #:kind 'dont-care)
(set #f) 'pos 'neg)]) (mutable-set #f) 'pos 'neg)])
(set-add! s "x"))) (set-add! s "x")))
(test/neg-blame (test/neg-blame
'set/c29 'set/c29
'(let ([s (contract (set/c integer? #:lazy? #f) '(let ([s (contract (set/c integer? #:lazy? #f #:kind 'mutable)
(set 0) 'pos 'neg)]) (mutable-set 0) 'pos 'neg)])
(set-add! s "x"))) (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) (λ (blame)
(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 (blame-add-element-context blame #t)))
(define set/c-lazy-late-neg-proj (cond
(λ (val neg-party) [lazy?
(λ (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 (chaperone-hash-set
[(set? val) val
(chaperone-hash-set pos-interpose
val (λ (val ele) (late-neg-neg-proj ele neg-party))
pos-interpose pos-interpose
(λ (val ele) ele) impersonator-prop:contracted ctc
pos-interpose impersonator-prop:blame (cons blame neg-party)))]
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]
[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)
(define w/chaperone (cond
(cond [(set? val)
[(set? val) val] (chaperone-hash-set
[else (for/fold ([s (set-clear val)])
(chaperone-hash-set ([e (in-set val)])
val (set-add s (late-neg-pos-proj e neg-party)))
(λ (val ele) ele) #f #f #f
(λ (val ele) (late-neg-neg-proj ele neg-party)) impersonator-prop:contracted ctc
(λ (val ele) ele))])) impersonator-prop:blame (cons blame neg-party))]
(chaperone-hash-set [else
(for/set ([ele (in-set w/chaperone)]) (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
(late-neg-pos-proj ele neg-party)) (for ([ele (in-list (set->list val))])
(chaperone-hash-set (set-remove! val ele)
val (set-add! val (late-neg-pos-proj ele neg-party)))
#f #f #f (chaperone-hash-set
impersonator-prop:contracted val
ctc)))]))) 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 (generic-set-late-neg-projection ctc chaperone-ctc?)
(define elem/c (set-contract-elem/c ctc)) (define elem/c (set-contract-elem/c ctc))