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

port async-channel/c to late-neg proj

Browse Source 
and drop other projection implementations
(mostly to reduce the testing burden)
This commit is contained in:
Robby Findler 2015-12-30 15:23:25 -06:00
parent 9ee264a0ea
commit cb2af327e6
1 changed files with 16 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
racket/collects/racket/async-channel.rkt
View File

@ -197,16 +197,10 @@
(define (add-async-channel-context blame) (define (add-async-channel-context blame)
(blame-add-context blame "a value passed through")) (blame-add-context blame "a value passed through"))
(define (check-async-channel/c ctc val blame) (define (check-async-channel/c ctc val blame neg-party)
(unless (async-channel? val) (unless (async-channel? val)
(raise-blame-error blame val '(expected "an async channel" given: "~e") val))) (raise-blame-error blame val #:missing-party neg-party
'(expected "an async channel" given: "~e") val)))
(define (check-async-channel/c-np ctc val blame)
(if (async-channel? val)
#f
(λ (neg-party)
(raise-blame-error blame #:missing-party neg-party
val '(expected "an async channel" given: "~e") val))))
(define ((async-channel/c-first-order ctc) val) (define ((async-channel/c-first-order ctc) val)
(async-channel? val)) (async-channel? val))
@ -214,33 +208,19 @@
(define (async-channel/c-stronger? a b) (define (async-channel/c-stronger? a b)
(contract-stronger? (base-async-channel/c-content a) (base-async-channel/c-content b))) (contract-stronger? (base-async-channel/c-content a) (base-async-channel/c-content b)))
(define ((ho-val-first-projection impersonate/chaperone-async-channel) ctc) (define ((late-neg-projection impersonate/chaperone-async-channel) ctc)
(define elem-ctc (base-async-channel/c-content ctc)) (define elem-ctc (base-async-channel/c-content ctc))
(define vfp (get/build-val-first-projection elem-ctc)) (define lnp (contract-late-neg-projection elem-ctc))
(λ (blame) (λ (blame)
(define async-channel-blame (add-async-channel-context blame)) (define pos-elem-proj (lnp blame))
(define pos-elem-proj (vfp async-channel-blame)) (define neg-elem-proj (lnp (blame-swap blame)))
(define neg-elem-proj (vfp (blame-swap async-channel-blame))) (λ (val neg-party)
(λ (val) (check-async-channel/c ctc val blame neg-party)
(or (check-async-channel/c-np ctc val blame) (impersonate/chaperone-async-channel val
(λ (neg-party) (λ (v) (pos-elem-proj v neg-party))
(impersonate/chaperone-async-channel (λ (v) (neg-elem-proj v neg-party))
val impersonator-prop:contracted ctc
(λ (v) ((pos-elem-proj v) neg-party)) impersonator-prop:blame blame))))
(λ (v) ((neg-elem-proj v) neg-party))
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))))))
(define ((ho-projection impersonate/chaperone-async-channel) ctc)
(let ([elem-ctc (base-async-channel/c-content ctc)])
(λ (blame)
(let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
[neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
(λ (val)
(check-async-channel/c ctc val blame)
(impersonate/chaperone-async-channel val pos-elem-proj neg-elem-proj
impersonator-prop:contracted ctc
impersonator-prop:blame blame))))))
(struct base-async-channel/c (content)) (struct base-async-channel/c (content))
@ -251,8 +231,7 @@
#:name async-channel/c-name #:name async-channel/c-name
#:first-order async-channel/c-first-order #:first-order async-channel/c-first-order
#:stronger async-channel/c-stronger? #:stronger async-channel/c-stronger?
#:val-first-projection (ho-val-first-projection chaperone-async-channel) #:late-neg-projection (late-neg-projection chaperone-async-channel)))
#:projection (ho-projection chaperone-async-channel)))
(struct impersonator-async-channel/c base-async-channel/c () (struct impersonator-async-channel/c base-async-channel/c ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -261,8 +240,7 @@
#:name async-channel/c-name #:name async-channel/c-name
#:first-order async-channel/c-first-order #:first-order async-channel/c-first-order
#:stronger async-channel/c-stronger? #:stronger async-channel/c-stronger?
#:val-first-projection (ho-val-first-projection impersonate-async-channel) #:late-neg-projection (late-neg-projection impersonate-async-channel)))
#:projection (ho-projection impersonate-async-channel)))
(define (async-channel/c elem) (define (async-channel/c elem)
(define ctc (coerce-contract 'async-channel/c elem)) (define ctc (coerce-contract 'async-channel/c elem))