diff --git a/collects/racket/private/for.rkt b/collects/racket/private/for.rkt index 8dbf91b4ee..1e3f17aa85 100644 --- a/collects/racket/private/for.rkt +++ b/collects/racket/private/for.rkt @@ -67,6 +67,7 @@ sequence? sequence-generate + sequence-generate* prop:sequence define-sequence-syntax @@ -1068,6 +1069,11 @@ next)))))) (gen-stream init))])) + (define (no-more) + (raise (exn:fail:contract "sequence has no more values" + (current-continuation-marks)))) + + (define (sequence-generate g) (unless (sequence? g) (raise-type-error 'sequence-generate "sequence" g)) @@ -1077,9 +1083,7 @@ (letrec ([more? #f] [prep-val! #f] [next #f]) - (letrec ([no-more (lambda () - (error "sequence has no more values"))] - [init-more? + (letrec ([init-more? (lambda () (prep-val!) (more?))] [init-next (lambda () (prep-val!) (next))] @@ -1126,6 +1130,29 @@ (values sequence-more? sequence-next))))))) + (define (sequence-generate* g) + (unless (sequence? g) + (raise-type-error 'sequence-generate* "sequence" g)) + (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) + (make-sequence #f g)]) + (letrec ([next! + (lambda (pos) + (if (if pos-cont? (pos-cont? pos) #t) + (call-with-values + (lambda () (pos->val pos)) + (lambda vals + (if (if pre-cont? (apply pre-cont? vals) #t) + (values vals + (lambda () + (if (if post-cont? + (apply post-cont? pos vals) + #t) + (next! (pos-next pos)) + (values #f no-more)))) + (values #f no-more)))) + (values #f no-more)))]) + (next! init)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; core `for/fold' syntax diff --git a/collects/racket/sequence.rkt b/collects/racket/sequence.rkt index a092ab3841..087a558c45 100644 --- a/collects/racket/sequence.rkt +++ b/collects/racket/sequence.rkt @@ -58,18 +58,32 @@ (raise-type-error 'sequence-tail "nonnegative exact integer" i)) (cond [(zero? i) seq] - [else (let loop ([s (sequence->stream seq)] [n i]) - (cond - [(zero? n) (in-stream s)] - [(stream-empty? s) - (raise-mismatch-error - 'sequence-ref - (format "sequence ended before ~e element~a: " - i - (if (= i 1) "" "s")) - seq)] - [else (loop (stream-rest s) - (sub1 n))]))])) + [(stream? seq) (stream-tail seq i)] + [else + (make-do-sequence + (lambda () + (let loop ([next (lambda () (sequence-generate* seq))] [n i]) + (cond + [(zero? n) + (let-values ([(vals next) (next)]) + (values (lambda (v+n) (apply values (car v+n))) + (lambda (v+n) + (let-values ([(vals next) ((cdr v+n))]) + (cons vals next))) + (cons vals next) + car + #f + #f))] + [else + (let-values ([(vals next) (next)]) + (if vals + (loop next (sub1 n)) + (raise-mismatch-error + 'sequence-ref + (format "sequence ended before ~e element~a: " + i + (if (= i 1) "" "s")) + seq)))]))))])) (define (sequence-append . l) (if (null? l) @@ -79,21 +93,66 @@ (apply in-sequences l)))) (define (sequence-map f s) - (unless (procedure? f) - (raise-type-error 'sequence-map "expects a procedure as the first argument, given ~e" f)) + (unless (procedure? f) (raise-type-error 'sequence-map "procedure" f)) + (unless (sequence? s) (raise-type-error 'sequence-map "sequence" s)) (if (stream? s) (stream-map f s) - (in-stream (stream-map f (sequence->stream s))))) + (make-do-sequence + (lambda () + (let-values ([(vals next) (sequence-generate* s)]) + (values (lambda (v+n) (apply f (car v+n))) + (lambda (v+n) + (let-values ([(vals next) ((cdr v+n))]) + (cons vals next))) + (cons vals next) + car + #f + #f)))))) + (define (sequence-filter f s) (unless (procedure? f) (raise-type-error 'sequence-filter "procedure" f)) (unless (sequence? s) (raise-type-error 'sequence-filter "sequence" s)) (if (stream? s) (stream-filter f s) - (in-stream (stream-filter f (sequence->stream s))))) + (make-do-sequence + (lambda () + (let loop ([next (lambda () (sequence-generate* s))]) + (let-values ([(vals next) (next)]) + (if (apply f vals) + (values (lambda (v+n) (apply values (car v+n))) + (lambda (v+n) + (let loop ([next (cdr v+n)]) + (let-values ([(vals next) (next)]) + (if (or (not vals) + (apply f vals)) + (cons vals next) + (loop next))))) + (cons vals next) + car + #f + #f) + (loop next)))))))) (define (sequence-add-between s e) - (unless (sequence? s) (raise-type-error 'sequence-ad-between "sequence" s)) + (unless (sequence? s) (raise-type-error 'sequence-add-between "sequence" s)) (if (stream? s) (stream-add-between s e) - (in-stream (stream-add-between (sequence->stream s) e)))) + (make-do-sequence + (lambda () + (let-values ([(vals next) (sequence-generate* s)]) + (values (lambda (v+n) (let ([vals (car v+n)]) + (if (eq? vals #t) + e + (apply values vals)))) + (lambda (v+n) + (if (eq? (car v+n) #t) + (cdr v+n) + (let-values ([(vals next) ((cdr v+n))]) + (if vals + (cons #t (cons vals next)) + (cons #f next))))) + (cons vals next) + car + #f + #f)))))) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index 456f7345dc..807923cff0 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -63,11 +63,17 @@ thunk that returns procedures to implement a sequence, and the type to implement its implicit conversion to a sequence. For most sequence types, extracting elements from a sequence has no -side-effect on the original sequence value; for example, extracting the -sequence of elements from a list does not change the list. For other -sequence types, each extraction implies a side effect; for example, -extracting the sequence of bytes from a port causes the bytes to be read -from the port. +side-effect on the original sequence value; for example, extracting +the sequence of elements from a list does not change the list. For +other sequence types, each extraction implies a side effect; for +example, extracting the sequence of bytes from a port causes the bytes +to be read from the port. A sequence's state may either span all uses +of the sequence, as for a port, or it may be confined to each distinct +time that a sequence is @deftech{initiate}d by a @racket[for] form, +@racket[sequence->stream], @racket[sequence-generate], or +@racket[sequence-generate*]. Concretely, the thunk passed to +@racket[make-do-sequence] is called to @tech{initiate} the sequence +each time the sequence is used. Individual elements of a sequence typically correspond to single values, but an element may also correspond to multiple values. For example, a @@ -322,7 +328,8 @@ in the sequence. (or/c ((any/c) () #:rest list? . ->* . any/c) #f)))]) sequence?]{ Returns a sequence whose elements are generated by the procedures and - initial value returned by the thunk. The sequence is defined in terms + initial value returned by the thunk, which is called to @tech{initiate} + the sequence. The initiated sequence is defined in terms of a @defterm{position}, which is initialized to the third result of the thunk, and the @defterm{element}, which may consist of multiple values. @@ -335,14 +342,14 @@ in the sequence. @item{The second result is a @scheme[_next-pos] procedure that takes the current position and returns the next position.} @item{The third result is the initial position.} - @item{The fourth result is a @racket[_continue-with-val?] function that + @item{The fourth result is a @racket[_continue-with-pos?] function that takes the current position and returns a true result if the sequence includes the value(s) for the current position, and false if the sequence should end instead of including the value(s). Alternatively, the fourth result can be @racket[#f] to indicate that the sequence should always include the current value(s).} - @item{The fifth result is a @racket[_continue-with-pos?] function that is + @item{The fifth result is a @racket[_continue-with-val?] function that is like the fourth result, but it takes the current element value(s) instead of the current position. Alternatively, the fifth result can be @@ -394,7 +401,8 @@ in the sequence. @defproc[(sequence->stream [seq sequence?]) stream?]{ Coverts a sequence to a @tech{stream}, which supports the - @racket[stream-first] and @racket[stream-rest] operations. The + @racket[stream-first] and @racket[stream-rest] operations. Creation + of the stream eagerly @tech{initiates} the sequence, but the stream lazily draws elements from the sequence, caching each element so that @racket[stream-first] produces the same result each time is applied to a stream. @@ -406,12 +414,25 @@ in the sequence. @defproc[(sequence-generate [seq sequence?]) (values (-> boolean?) (-> any))]{ - Returns two thunks to extract elements from the sequence. The first + @tech{Initiates} a sequence and returns two thunks to extract elements + from the sequence. The first returns @scheme[#t] if more values are available for the sequence. The second returns the next element (which may be multiple values) from the sequence; if no more elements are available, the @exnraise[exn:fail:contract].} +@defproc[(sequence-generate* [seq sequence?]) + (values (or/c list? #f) + (-> (values (or/c list? #f) procedure?)))]{ + Like @racket[sequence-generate*], but avoids state (aside from any + inherent in the sequence) by returning a list of values the sequence's + first element---or @racket[#f] if the sequence is empty---and a thunk + to continue with the sequence; the result of the thunk is the same + as the result of @racket[sequence-generate*], but for the second + element of the sequence, and so on. If the thunk is called when the + element result is @racket[#f] (indicating no further values in the sequence), + the @exnraise[exn:fail:contract].} + @; ---------------------------------------------------------------------- @subsection[#:tag "more-sequences"]{Sequence Combinations} @@ -441,9 +462,11 @@ in the sequence. Returns a sequence equivalent to @scheme[s], except that the first @scheme[i] elements are omitted. - In case extracting elements from @racket[s] involves a side effect, - they will not be extracted until the first element is extracted from - the resulting sequence.} + In case @tech[#:key "initiate"]{initiating} @racket[s] involves a + side effect, the sequence @racket[s] is not @tech{initiate}d + until the resulting sequence is @tech{initiate}d, at which point the + first @racket[i] elements are extracted from + the sequence.} @defproc[(sequence-append [s sequence?] ...) sequence?]{ diff --git a/collects/tests/racket/sequence.rktl b/collects/tests/racket/sequence.rktl index 55047d6b67..7752da274d 100644 --- a/collects/tests/racket/sequence.rktl +++ b/collects/tests/racket/sequence.rktl @@ -172,4 +172,79 @@ (test #t stream? (sequence-filter odd? (in-range 3))) (test #f stream? (sequence-filter odd? (vector 1 2 3))) +;; ---------------------------------------- + +;; Check interaction of sequence operations and side-effecting streams: + +(let ([s (open-input-string "012345")]) + (test #\0 peek-char s) + (let ([t (sequence-tail s 3)]) + (test #\0 peek-char s) + (test (char->integer #\3) 'tail (for/first ([c t]) c)))) + +(let ([s (open-input-string "012345")]) + (test #\0 peek-char s) + (let ([t (sequence-map add1 s)]) + (test #\0 peek-char s) + (test (list (char->integer #\1) + (char->integer #\2) + (char->integer #\3)) + 'map + (for/list ([c t] + [n (in-range 3)]) + c)) + ;; #\3 was read, but loop ended by `in-range' + (test #\4 peek-char s))) + +(let ([s (open-input-string "012345")]) + (let ([t (sequence-tail s 6)]) + (test '() 'tail (for/list ([i t]) i)))) + +(let ([s (open-input-string "01234567")]) + (test #\0 peek-char s) + (let ([t (sequence-filter even? s)]) + (test #\0 peek-char s) + (test (list (char->integer #\0) + (char->integer #\2) + (char->integer #\4)) + 'map + (for/list ([c t] + [n (in-range 3)]) + c)) + ;; #\6 was read, but loop ended by `in-range' + (test #\7 peek-char s))) + +(let ([s (open-input-string "0123")]) + (test #\0 peek-char s) + (let ([t (sequence-add-between s #f)]) + (test #\0 peek-char s) + (test (list (char->integer #\0) + #f + (char->integer #\1) + #f + (char->integer #\2) + #f + (char->integer #\3)) + 'map + (for/list ([c t] + [n (in-range 30)]) + c)) + (test eof peek-char s))) + +(let ([s (open-input-string "012345")]) + (test #\0 peek-char s) + (let ([t (sequence-add-between s #f)]) + (test #\0 peek-char s) + (test (list (char->integer #\0) + #f + (char->integer #\1)) + 'map + (for/list ([c t] + [n (in-range 3)]) + c)) + ;; #\2 was read, but loop ended by `in-range' + (test #\3 peek-char s))) + +;; ---------------------------------------- + (report-errs)