From 8323e679eb905085243152d728735cd9ae74bd06 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 1 Nov 2013 13:18:46 -0400 Subject: [PATCH] Add channel contracts --- .../scribblings/reference/contracts.scrbl | 19 +++ .../tests/racket/contract/channel.rkt | 123 ++++++++++++++++++ racket/collects/racket/HISTORY.txt | 1 + .../collects/racket/contract/private/misc.rkt | 63 +++++++++ 4 files changed, 206 insertions(+) create mode 100644 pkgs/racket-pkgs/racket-test/tests/racket/contract/channel.rkt diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index 48d8343a8d..09744a445b 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -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) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/channel.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/channel.rkt new file mode 100644 index 0000000000..4d7e53e028 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/channel.rkt @@ -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))) diff --git a/racket/collects/racket/HISTORY.txt b/racket/collects/racket/HISTORY.txt index 95879a5c4d..07f7e520b6 100644 --- a/racket/collects/racket/HISTORY.txt +++ b/racket/collects/racket/HISTORY.txt @@ -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:... diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index dd66b70193..bfb22cd9b1 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -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)))