Add channel contracts
This commit is contained in:
parent
1b47cf5898
commit
8323e679eb
|
@ -548,6 +548,25 @@ to the input. The result will be a copy for immutable hash tables, and either a
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@defproc[(channel/c [val contract?])
|
||||||
|
contract?]{
|
||||||
|
Produces a contract that recognizes @tech{channel}s that communicate
|
||||||
|
values as specified by the @racket[val] argument.
|
||||||
|
|
||||||
|
If the @racket[val] argument is a chaperone contract, then the resulting contract
|
||||||
|
is a chaperone contract. Otherwise, the resulting contract is an impersonator
|
||||||
|
contract. When a channel contract is applied to a channel, the resulting channel
|
||||||
|
is not @racket[eq?] to the input.
|
||||||
|
|
||||||
|
@examples[#:eval (contract-eval)
|
||||||
|
(define/contract chan
|
||||||
|
(channel/c string?)
|
||||||
|
(make-channel))
|
||||||
|
(thread (λ () (channel-get chan)))
|
||||||
|
(channel-put chan 'not-a-string)
|
||||||
|
]}
|
||||||
|
|
||||||
|
|
||||||
@defform/subs[#:literals (values)
|
@defform/subs[#:literals (values)
|
||||||
(prompt-tag/c contract ... maybe-call/cc)
|
(prompt-tag/c contract ... maybe-call/cc)
|
||||||
([maybe-call/cc (code:line)
|
([maybe-call/cc (code:line)
|
||||||
|
|
123
pkgs/racket-pkgs/racket-test/tests/racket/contract/channel.rkt
Normal file
123
pkgs/racket-pkgs/racket-test/tests/racket/contract/channel.rkt
Normal file
|
@ -0,0 +1,123 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require "test-util.rkt")
|
||||||
|
|
||||||
|
(parameterize ([current-contract-namespace (make-basic-contract-namespace)])
|
||||||
|
(test/spec-passed
|
||||||
|
'channel/c1
|
||||||
|
'(contract (channel/c symbol?)
|
||||||
|
(make-channel)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'channel/c1b
|
||||||
|
'(let ([ch (contract (channel/c symbol?)
|
||||||
|
(make-channel)
|
||||||
|
'pos
|
||||||
|
'neg)])
|
||||||
|
(thread (λ () (channel-get ch)))
|
||||||
|
(channel-put ch 'x)))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'channel/c1c
|
||||||
|
'(let ([ch (contract (channel/c symbol?)
|
||||||
|
(make-channel)
|
||||||
|
'pos
|
||||||
|
'neg)])
|
||||||
|
(thread (λ () (channel-get ch)))
|
||||||
|
(channel-put ch 5)))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'channel/c1d
|
||||||
|
'(let ([ch (contract (channel/c symbol?)
|
||||||
|
(make-channel)
|
||||||
|
'pos
|
||||||
|
'neg)])
|
||||||
|
(thread (λ () (channel-get ch)))
|
||||||
|
(channel-put ch 5)))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'channel/c1e
|
||||||
|
'(let ([ch (contract (channel/c symbol?)
|
||||||
|
(make-channel)
|
||||||
|
'pos
|
||||||
|
'neg)])
|
||||||
|
(channel-put ch 5)))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'channel/c2
|
||||||
|
'(contract (channel/c symbol?)
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch 'x)))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'channel/c2b
|
||||||
|
'(contract (channel/c symbol?)
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch 3)))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'channel/c3
|
||||||
|
'(channel-get
|
||||||
|
(contract (channel/c symbol?)
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch 3)))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg)))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'channel/c4
|
||||||
|
'(contract (channel/c symbol?)
|
||||||
|
"not a channel"
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'channel/c5
|
||||||
|
'(channel-get
|
||||||
|
(contract (channel/c symbol?)
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch 3)))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg)))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'channel/c6
|
||||||
|
'((channel-get
|
||||||
|
(contract (channel/c (-> number? number?))
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch (λ (x) x))))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
5))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'channel/c6b
|
||||||
|
'((channel-get
|
||||||
|
(contract (channel/c (-> number? number?))
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch (λ (x) 'bad))))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
5))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'channel/c6c
|
||||||
|
'((channel-get
|
||||||
|
(contract (channel/c (-> number? number?))
|
||||||
|
(let ([ch (make-channel)])
|
||||||
|
(thread (λ () (channel-put ch (λ (x) 3))))
|
||||||
|
ch)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
'bad)))
|
|
@ -1,6 +1,7 @@
|
||||||
Version 5.90.0.11
|
Version 5.90.0.11
|
||||||
Added flrandom and unsafe-flrandom
|
Added flrandom and unsafe-flrandom
|
||||||
xml: added a #:insert-newlines? argument to write-xexpr
|
xml: added a #:insert-newlines? argument to write-xexpr
|
||||||
|
racket/contract: added channel/c
|
||||||
|
|
||||||
Version 5.90.0.10
|
Version 5.90.0.10
|
||||||
Changed serializable-struct, etc. to provide deserialized-info:...
|
Changed serializable-struct, etc. to provide deserialized-info:...
|
||||||
|
|
|
@ -39,6 +39,8 @@
|
||||||
prompt-tag/c
|
prompt-tag/c
|
||||||
continuation-mark-key/c
|
continuation-mark-key/c
|
||||||
|
|
||||||
|
channel/c
|
||||||
|
|
||||||
chaperone-contract?
|
chaperone-contract?
|
||||||
impersonator-contract?
|
impersonator-contract?
|
||||||
flat-contract?
|
flat-contract?
|
||||||
|
@ -1124,6 +1126,67 @@
|
||||||
#:name continuation-mark-key/c-name))
|
#:name continuation-mark-key/c-name))
|
||||||
|
|
||||||
|
|
||||||
|
;; channel/c
|
||||||
|
(define/subexpression-pos-prop (channel/c ctc-arg)
|
||||||
|
(define ctc (coerce-contract 'channel/c ctc-arg))
|
||||||
|
(cond [(chaperone-contract? ctc)
|
||||||
|
(chaperone-channel/c ctc)]
|
||||||
|
[else
|
||||||
|
(impersonator-channel/c ctc)]))
|
||||||
|
|
||||||
|
(define (channel/c-name ctc)
|
||||||
|
(build-compound-type-name
|
||||||
|
'channel/c
|
||||||
|
(base-channel/c-ctc ctc)))
|
||||||
|
|
||||||
|
(define ((channel/c-proj proxy) ctc)
|
||||||
|
(define ho-proj
|
||||||
|
(contract-projection (base-channel/c-ctc ctc)))
|
||||||
|
(λ (blame)
|
||||||
|
(define proj1 (λ (ch) (values ch (λ (v) ((ho-proj blame) v)))))
|
||||||
|
(define proj2 (λ (ch v) ((ho-proj (blame-swap blame)) v)))
|
||||||
|
(λ (val)
|
||||||
|
(unless (contract-first-order-passes? ctc val)
|
||||||
|
(raise-blame-error
|
||||||
|
blame val
|
||||||
|
'(expected: "~s" given: "~e")
|
||||||
|
(contract-name ctc)
|
||||||
|
val))
|
||||||
|
(proxy val proj1 proj2
|
||||||
|
impersonator-prop:contracted ctc))))
|
||||||
|
|
||||||
|
(define ((channel/c-first-order ctc) v)
|
||||||
|
(channel? v))
|
||||||
|
|
||||||
|
(define (channel/c-stronger? this that)
|
||||||
|
(and (base-channel/c? that)
|
||||||
|
(contract-stronger?
|
||||||
|
(base-channel/c-ctc this)
|
||||||
|
(base-channel/c-ctc that))))
|
||||||
|
|
||||||
|
(define-struct base-channel/c (ctc))
|
||||||
|
|
||||||
|
(define-struct (chaperone-channel/c base-channel/c)
|
||||||
|
()
|
||||||
|
#:property prop:custom-write custom-write-property-proc
|
||||||
|
#:property prop:chaperone-contract
|
||||||
|
(build-chaperone-contract-property
|
||||||
|
#:projection (channel/c-proj chaperone-channel)
|
||||||
|
#:first-order channel/c-first-order
|
||||||
|
#:stronger channel/c-stronger?
|
||||||
|
#:name channel/c-name))
|
||||||
|
|
||||||
|
(define-struct (impersonator-channel/c base-channel/c)
|
||||||
|
()
|
||||||
|
#:property prop:custom-write custom-write-property-proc
|
||||||
|
#:property prop:contract
|
||||||
|
(build-contract-property
|
||||||
|
#:projection (channel/c-proj impersonate-channel)
|
||||||
|
#:first-order channel/c-first-order
|
||||||
|
#:stronger channel/c-stronger?
|
||||||
|
#:name channel/c-name))
|
||||||
|
|
||||||
|
|
||||||
(define (flat-contract-predicate x)
|
(define (flat-contract-predicate x)
|
||||||
(contract-struct-first-order
|
(contract-struct-first-order
|
||||||
(coerce-flat-contract 'flat-contract-predicate x)))
|
(coerce-flat-contract 'flat-contract-predicate x)))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user