From 714b7684fe3b5e11725795cdd2a3458f359ac63f Mon Sep 17 00:00:00 2001 From: Alexis King Date: Sun, 8 Feb 2015 00:19:32 -0800 Subject: [PATCH] Add stream/c contract for adding contracts on stream contents --- .../scribblings/reference/sequences.scrbl | 24 ++++ .../tests/racket/contract/stream.rkt | 34 ++++++ racket/collects/racket/stream.rkt | 105 +++++++++++++++++- 3 files changed, 162 insertions(+), 1 deletion(-) create mode 100644 pkgs/racket-test/tests/racket/contract/stream.rkt diff --git a/pkgs/racket-doc/scribblings/reference/sequences.scrbl b/pkgs/racket-doc/scribblings/reference/sequences.scrbl index 19571b16a3..f410905709 100644 --- a/pkgs/racket-doc/scribblings/reference/sequences.scrbl +++ b/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] @; ====================================================================== diff --git a/pkgs/racket-test/tests/racket/contract/stream.rkt b/pkgs/racket-test/tests/racket/contract/stream.rkt new file mode 100644 index 0000000000..81c15f22e5 --- /dev/null +++ b/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))))) diff --git a/racket/collects/racket/stream.rkt b/racket/collects/racket/stream.rkt index 3bf9d8d713..e6b746b2bb 100644 --- a/racket/collects/racket/stream.rkt +++ b/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)))