Add stream/c contract for adding contracts on stream contents

pkgs/racket-doc/scribblings/reference/sequences.scrbl

@@ -940,6 +940,30 @@ stream, but plain lists can be used as streams, and functions such as
   the methods in @racket[gen:stream].
 }
 
+@defproc[(stream/c [c contract?]) contract?]{
+Returns a contract that recognizes streams. All elements of the stream must match
+@racket[c].
+
+If the @racket[c] argument is a flat contract or a chaperone contract, then the
+result will be a chaperone contract. Otherwise, the result will be an
+impersonator contract.
+
+When an @racket[stream/c] contract is applied to an asynchronous channel,
+the result is not @racket[eq?] to the input. The result will be either a
+@tech{chaperone} or @tech{impersonator} of the input depending on the type of
+contract.
+
+Contracts on streams are evaluated lazily by necessity (since streams may be
+infinite). Contract violations will not be raised until the value in violation
+is retrieved from the stream. As an exception to this rule, streams that are
+lists are checked immediately, as if @racket[c] had been used with
+@racket[listof].
+
+If a contract is applied to a stream, and that stream is subsequently used as
+the tail of another stream (as the second parameter to @racket[stream-cons]),
+the new elements will not be checked with the contract, but the tail's elements
+will still be enforced.}
+
 @close-eval[sequence-evaluator]
 
 @; ======================================================================

pkgs/racket-test/tests/racket/contract/stream.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+(require "test-util.rkt")
+
+(parameterize ([current-contract-namespace (make-full-contract-namespace 'racket/stream)])
+  (test/pos-blame
+   'stream/c1
+   '(contract (stream/c any/c) #f 'pos 'neg))
+  
+  (test/pos-blame
+   'stream/c2
+   '(stream-first (contract (stream/c integer?) (stream #f) 'pos 'neg)))
+  
+  (test/pos-blame
+   'stream/c3
+   '(stream-first (contract (stream/c (and/c integer? positive?)) (in-naturals) 'pos 'neg)))
+  
+  (test/pos-blame
+   'stream/c4
+   '(contract (stream/c integer?) '(0 1 2 #f) 'pos 'neg))
+  
+  (test/spec-passed
+   'stream/c5
+   '(contract (stream/c integer?) (stream #f) 'pos 'neg))
+  
+  (test/spec-passed
+   'stream/c6
+   '(stream-first (stream-rest (contract (stream/c (and/c integer? (or/c 0 positive?)))
+                                         (in-naturals) 'pos 'neg))))
+  
+  (test/pos-blame
+   'stream/c7
+   '(stream-first (stream-rest (contract (stream/c (and/c integer? (or/c 0 positive?)))
+                                         (stream 0 -1) 'pos 'neg)))))

racket/collects/racket/stream.rkt

@@ -1,6 +1,9 @@
 #lang racket/base
 
 (require racket/private/generic
+         racket/generic
+         racket/contract/base
+         racket/contract/combinator
          (rename-in "private/for.rkt"
                     [stream-ref stream-get-generics])
          "private/sequence.rkt"
@@ -36,7 +39,9 @@
          stream-fold
          stream-filter
          stream-add-between
-         stream-count)
+         stream-count
+         
+         stream/c)
 
 (define-syntax gen:stream
   (make-generic-info (quote-syntax prop:stream)
@@ -179,3 +184,101 @@
          (cond [(stream-empty? s) empty-stream]
                [else (stream-cons e (stream-cons (stream-first s)
                                                  (loop (stream-rest s))))])))))
+
+;; Impersonators and Chaperones ----------------------------------------------------------------------
+;; (these are private because they would fail on lists, which satisfy `stream?`)
+
+(define (impersonate-stream s first-proc rest-proc . props)
+  (impersonate-generics
+   gen:stream
+   ; the struct-info param is a hack, see PR 14970
+   (apply impersonate-struct s struct-info (λ (a b) (values a b)) props)
+   [stream-first
+    (λ (stream-first)
+      (impersonate-procedure stream-first
+                             (λ (s) (values (λ (v) (first-proc v)) s))))]
+   [stream-rest
+    (λ (stream-rest)
+      (impersonate-procedure stream-rest
+                             (λ (s) (values (λ (v) (rest-proc v)) s))))]))
+
+(define (chaperone-stream s first-proc rest-proc . props)
+  (chaperone-generics
+   gen:stream
+   ; the struct-info param is a hack, see PR 14970
+   (apply chaperone-struct s struct-info (λ (a b) (values a b)) props)
+   [stream-first
+    (λ (stream-first)
+      (chaperone-procedure stream-first
+                           (λ (s) (values (λ (v) (first-proc v)) s))))]
+   [stream-rest
+    (λ (stream-rest)
+      (chaperone-procedure stream-rest
+                           (λ (s) (values (λ (v) (rest-proc v)) s))))]))
+
+;; Stream contracts ----------------------------------------------------------------------------------
+
+(define (stream/c-name ctc)
+  (define elem-name (contract-name (base-stream/c-content ctc)))
+  (apply build-compound-type-name
+         'stream/c
+         elem-name
+         '()))
+
+(define (add-stream-context blame)
+  (blame-add-context blame "a value generated by"))
+
+(define (check-stream/c ctc val blame)
+  (unless (stream? val)
+    (raise-blame-error blame val '(expected "a stream" given: "~e") val)))
+
+(define (stream/c-stronger? a b)
+  (contract-stronger? (base-stream/c-content a) (base-stream/c-content b)))
+
+; streams are lazy, so we need to contract the rest of the stream lazily (which can be a list)
+(define (contract-stream-rest v ctc blame)
+  (define elem-ctc (base-stream/c-content ctc))
+  (define new-ctc (if (list? v) (listof elem-ctc) ctc))
+  (((contract-projection new-ctc) blame) v))
+
+(define ((ho-projection impersonate/chaperone-stream) ctc)
+  (let ([elem-ctc (base-stream/c-content ctc)])
+    (λ (blame)
+      (define stream-blame (add-stream-context blame))
+      (define pos-elem-proj ((contract-projection elem-ctc) stream-blame))
+      (λ (val)
+        (check-stream/c ctc val stream-blame)
+        (if (list? val)
+            (contract-stream-rest val ctc stream-blame)
+            (impersonate/chaperone-stream
+             val
+             (λ (v) (pos-elem-proj v))
+             (λ (v) (contract-stream-rest v ctc stream-blame))
+             impersonator-prop:contracted ctc
+             impersonator-prop:blame stream-blame))))))
+
+(struct base-stream/c (content))
+
+(struct chaperone-stream/c base-stream/c ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:name stream/c-name
+   #:first-order stream?
+   #:stronger stream/c-stronger?
+   #:projection (ho-projection chaperone-stream)))
+
+(struct impersonator-stream/c base-stream/c ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:contract
+  (build-contract-property
+   #:name stream/c-name
+   #:first-order stream?
+   #:stronger stream/c-stronger?
+   #:projection (ho-projection impersonate-stream)))
+
+(define (stream/c elem)
+  (define ctc (coerce-contract 'stream/c elem))
+  (if (chaperone-contract? ctc)
+      (chaperone-stream/c ctc)
+      (impersonator-stream/c ctc)))