racket/sequence repairs

including addition of `sequence-generate*'

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 ()
+          (letrec ([init-more?
-                              (error "sequence has no more values"))]
-                   [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
 

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])
+   [(stream? seq) (stream-tail seq i)]
-           (cond
+   [else
-            [(zero? n) (in-stream s)]
+    (make-do-sequence
-            [(stream-empty? s) 
+     (lambda ()
-             (raise-mismatch-error 
+       (let loop ([next (lambda () (sequence-generate* seq))] [n i])
-              'sequence-ref
+         (cond
-              (format "sequence ended before ~e element~a: "
+          [(zero? n)
-                      i
+           (let-values ([(vals next) (next)])
-                      (if (= i 1) "" "s"))
+             (values (lambda (v+n) (apply values (car v+n)))
-              seq)]
+                     (lambda (v+n) 
-            [else (loop (stream-rest s)
+                       (let-values ([(vals next) ((cdr v+n))])
-                        (sub1 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)
+  (unless (procedure? f) (raise-type-error 'sequence-map "procedure" f))
-    (raise-type-error 'sequence-map "expects a procedure as the first argument, given ~e" 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))))))

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
+side-effect on the original sequence value; for example, extracting
-sequence of elements from a list does not change the list.  For other
+the sequence of elements from a list does not change the list.  For
-sequence types, each extraction implies a side effect; for example,
+other sequence types, each extraction implies a side effect; for
-extracting the sequence of bytes from a port causes the bytes to be read
+example, extracting the sequence of bytes from a port causes the bytes
-from the port.
+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,
+  In case @tech[#:key "initiate"]{initiating} @racket[s] involves a
-  they will not be extracted until the first element is extracted from
+  side effect, the sequence @racket[s] is not @tech{initiate}d
-  the resulting sequence.}
+  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?]{

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)