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)
|
||||
(prompt-tag/c contract ... maybe-call/cc)
|
||||
([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
|
||||
Added flrandom and unsafe-flrandom
|
||||
xml: added a #:insert-newlines? argument to write-xexpr
|
||||
racket/contract: added channel/c
|
||||
|
||||
Version 5.90.0.10
|
||||
Changed serializable-struct, etc. to provide deserialized-info:...
|
||||
|
|
|
@ -39,6 +39,8 @@
|
|||
prompt-tag/c
|
||||
continuation-mark-key/c
|
||||
|
||||
channel/c
|
||||
|
||||
chaperone-contract?
|
||||
impersonator-contract?
|
||||
flat-contract?
|
||||
|
@ -1124,6 +1126,67 @@
|
|||
#: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)
|
||||
(contract-struct-first-order
|
||||
(coerce-flat-contract 'flat-contract-predicate x)))
|
||||
|
|
Loading…
Reference in New Issue
Block a user