Add channel contracts

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)

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

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

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