Add channel contracts

This commit is contained in:
Asumu Takikawa 2013-11-01 13:18:46 -04:00
parent 1b47cf5898
commit 8323e679eb
4 changed files with 206 additions and 0 deletions

View File

@ -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)

View 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)))

View File

@ -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:...

View File

@ -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)))