[plt-scheme] generators with sequences

I wrote a generator syntax for use with the v4 `for' sequences. Some 
example usages are below but the main point is you can say (yield 5) 
when you want a function to produce a value that can be used as a 
sequence. It took me a few tries to get this right and I left most of my 
attempts in so others can maybe learn what not to do. This could go into 
collects/, so if anyone has any improvements please share! The last 
attempt (test4) is my best effort so far.

#lang scheme

(require scheme/control)
(require scheme/stxparam)
 
(define (check v1 v2)
  (when (not (equal? v1 v2))
    (printf "test failed expected ~a actual ~a\n" v1 v2)))

(define (do-tests for-function)
  (check (for/list ([i (in-range 0 10)])
                   i)
         (for/list ([i (in-range 0 10)])
                   i))

  #;
  (let ([x 0])
    (for/list ([i (for-function)])
              (printf "i ~a x ~a\n" i x)
              (set! x (add1 x))
              i))

  (check (for/list ([i (in-range 0 10)])
                   i)
         (let ([x 0])
           (for/list ([i (for-function)])
                     ;; (printf "i ~a x ~a\n" i x)
                     (set! x (add1 x))
                     i)))

  (for/list ([i (for-function)]
             [j (in-range 0 5)])
            ;; (printf "i ~a j ~a\n" i j)
            (list i j))

  (check (for/list ([i (in-range 0 10)]
                    [j (in-range 0 5)])
                   (list i j))
         (for/list ([i (for-function)]
                    [j (in-range 0 5)])
                   ;; (printf "i ~a j ~a\n" i j)
              (list i j)))

  (check (for/list ([i (in-range 0 10)]
                    [j (in-range 0 10)])
                   (list i j))
         (for/list ([i (for-function)]
                    [j (for-function)])
                   (list i j)))

  (check (for/list ([(v vi) (in-indexed (in-range 0 10))])
                   (list v vi))
         (for/list ([(v vi) (in-indexed (for-function))])
                   (list v vi)))

  (check (for/list ([v (in-sequences (in-range 0 10) (in-range 0 10))])
                   v)
         (for/list ([v (in-sequences (for-function) (for-function))])
                   v))

  ;; doesn't work yet
  #;
  (check (for/list ([v (in-cycle (in-range 0 10))]
                    [x (in-range 0 100)])
                   v)
         (for/list ([v (in-cycle (for-function))]
                    [x (in-range 0 100)])
                   (printf "~a ~a\n" v x)
                   v))
  )

;; completely broken version using call/cc and creating too many 
sequence objects
(define test1
  (let ()
    (define-syntax yield
      (syntax-rules ()
        [(_ yielder value)
         (call/cc (lambda (ret)
                    (let ([s (make-do-sequence (lambda ()
                                                 (values
                                                   (lambda (i) value)
                                                   (lambda (x) (ret #f))
                                                   0
                                                   (lambda (x) #t)
                                                   (lambda (v) (eq? v 
value))
                                                   (lambda (x v) #t))))])
                      (yielder s))))]))

    (define-syntax define-generator
      (syntax-rules ()
        [(_ ret (name args ...) body0 bodies ...)
         (define (name args ...)
           (call/cc (lambda (ret)
                      body0 bodies ...
                      (make-do-sequence (lambda ()
                                          (values
                                            (lambda (i) (void))
                                            (lambda (x) (void))
                                            0
                                            (lambda (x) #f)
                                            (lambda (x) #f)
                                            (lambda (x y) #f))))
                      )))]))


    (define-generator yielder (blah)
                      (for ([x (in-range 0 10)])
                           (yield yielder x)))

    (printf "test1\n")
    (do-tests blah)
    ))

;; working version using prompt/control
(define test2
  (let ()
    (define-syntax yield
      (syntax-rules ()
        [(_ value)
         ;; Capture the current delimited continuation, f, and pass back 
to the last prompt a,
         ;; value and a function that installs a new prompt and 
continues where f left off.
         (control f (values value (lambda () (prompt (f)))))]))

    (define-syntax lambda-generator
      (syntax-rules ()
        [(_ (args ...) body0 bodies ...)
         (lambda (args ...)
           (let* ([current (lambda ()
                             (prompt
                               body0 bodies ...
                               ;; (printf "now what\n")
                               (values #f #f)
                               ))]
                    [pos 0]
                    [seq (make-do-sequence (lambda ()
                                           (values
                                             (lambda (i) (let-values 
([(value next) (current)])
                                                           ;; (printf 
"Next value is ~a\n" value)
                                                           (set! current 
next)
                                                           value))
                                             (lambda (x) (add1 x))
                                             0
                                             (lambda (x) current)
                                             (lambda (v) current)
                                             (lambda (x v) current))))])
             seq))]))

    (define-syntax define-generator
      (syntax-rules ()
        [(_ (name args ...) body0 bodies ...)
         (define name (lambda-generator (args ...) body0 bodies ...))]))

    (define-generator (blah)
                      (for ([x (in-range 0 10)])
                           (yield x)))

    (printf "test2\n")
    (do-tests blah)

    #;
    (printf "test3\n")
    #;
    (do-tests (lambda ()
                (make-do-sequence (lambda ()
                                    (values
                                      (lambda (i) i)
                                      (lambda (x) (add1 x))
                                      0
                                      (lambda (x) (< x 10))
                                      (lambda (v) #t)
                                      (lambda (x v) #t))))))

    ;; a cute example
    #;
    (let ()
      ;; generate infinte list of unique names
      (define-generator (machine-names)
                        (define letters "abcdefghijklmnopqrstuvwxyz")
                        (let loop ([len 0])
                          ;; generates strings of length num
                          (define-generator (generate num)
                                            (for ([letter (in-string 
letters)])
                                                 (if (= num 0)
                                                   (yield (string letter))
                                                   (for ([l2 (generate 
(- num 1))])
                                                        (yield 
(string-append (string letter) l2))))))
                          (for ([str (generate len)])
                               (yield str))
                          (loop (add1 len))))
      (for ([s (machine-names)]
            [j (in-range 0 1000)])
           (printf "~a: ~a\n" j s)))

    ))

;; better version using shift/reset
(define test3
  (let ()
    (define-syntax yield
      (syntax-rules ()
        [(_ value)
         (shift f (values value f))]))

    (define-syntax lambda-generator
      (syntax-rules ()
        [(_ (args ...) body0 bodies ...)
         (lambda (args ...)
           (let* ([current (lambda ()
                             (reset
                               body0 bodies ...
                               ;; (printf "now what\n")
                               (values #f #f)
                               ))]
                    [pos 0]
                    [seq (make-do-sequence (lambda ()
                                           (values
                                             (lambda (i) (let-values 
([(value next) (current)])
                                                           ;; (printf 
"Next value is ~a\n" value)
                                                           (set! current 
next)
                                                           value))
                                             (lambda (x) (add1 x))
                                             0
                                             (lambda (x) current)
                                             (lambda (v) current)
                                             (lambda (x v) current))))])
             seq))]))

    (define-syntax define-generator
      (syntax-rules ()
        [(_ (name args ...) body0 bodies ...)
         (define name (lambda-generator (args ...) body0 bodies ...))]))

    (define-generator (blah)
                      (for ([x (in-range 0 10)])
                           (yield x)))

    (printf "test3\n")
    (do-tests blah)

    #;
    (printf "test3\n")
    #;
    (do-tests (lambda ()
                (make-do-sequence (lambda ()
                                    (values
                                      (lambda (i) i)
                                      (lambda (x) (add1 x))
                                      0
                                      (lambda (x) (< x 10))
                                      (lambda (v) #t)
                                      (lambda (x v) #t))))))

    ;; a cute example
    #;
    (let ()
      ;; generate infinte list of unique names
      (define-generator (machine-names)
                        (define letters "abcdefghijklmnopqrstuvwxyz")
                        (let loop ([len 0])
                          ;; generates strings of length num
                          (define-generator (generate num)
                                            (for ([letter (in-string 
letters)])
                                                 (if (= num 0)
                                                   (yield (string letter))
                                                   (for ([l2 (generate 
(- num 1))])
                                                        (yield 
(string-append (string letter) l2))))))
                          (for ([str (generate len)])
                               (yield str))
                          (loop (add1 len))))
      (for ([s (machine-names)]
            [j (in-range 0 1000)])
           (printf "~a: ~a\n" j s)))

    ))

;; better version of shift/reset using continuation tags
;; also use a unique value to determine the end of the sequence instead 
of using #f
(define test4
  (let ()
    (define-syntax-parameter yield (lambda (stx)
                                     (raise-syntax-error #f "yield is 
only bound inside a sequence generator")))

    (define-syntax lambda-generator
      (syntax-rules ()
        [(_ (args ...) body0 bodies ...)
         (lambda (args ...)
           (let* ([last (lambda () (void))]
                  ;; current is a function that invokes user code and 
produces values
                  [current (lambda ()
                             ;; a unique tag to jump to
                             (define tag (make-continuation-prompt-tag))
                             ;; give the value to the sequence
                             (define next (lambda (value)
                                            (shift-at tag f (values 
value f))))
                             (syntax-parameterize ([yield 
(make-rename-transformer #'next)])
                                                  (reset-at tag
                                                    body0 bodies ...
                                                    (values #f last)
                                                    )))]
                    [pos 0]
                    [seq (make-do-sequence (lambda ()
                                           (values
                                             ;; produce a value and a 
continuation
                                             (lambda (i) (let-values 
([(value next) (current)])
                                                           ;; set! is 
ugly but can we do better?
                                                           (set! current 
next)
                                                           value))
                                             (lambda (x) (add1 x))
                                             0
                                             (lambda (x) (not (eq? last 
current)))
                                             (lambda (v) (not (eq? last 
current)))
                                             (lambda (x v) (not (eq? 
last current))))))])
             seq))]))

    (define-syntax define-generator
      (syntax-rules ()
        [(_ (name args ...) body0 bodies ...)
         (define name (lambda-generator (args ...) body0 bodies ...))]))

    (define-generator (blah)
                      (for ([x (in-range 0 10)])
                           (yield x)))

    (printf "test4\n")
    (do-tests blah)

    (check (for/list ([i ((lambda-generator ()
                                           (for ([i (in-range 0 5)]) 
(yield #f))))])
                     i)
           (for/list ([i (in-range 0 5)])
                     #f))

    (check (for/list ([i ((lambda-generator ()
                                           (for ([i (in-range 0 5)])
                                                (yield
                                                  (reset
                                                    (for ([j (in-range 2 
5)])
                                                         (shift k (+ i 
j))))))))])
                     i)
           (for/list ([i (in-range 2 7)])
                     i))

    #;
    (printf "test3\n")
    #;
    (do-tests (lambda ()
                (make-do-sequence (lambda ()
                                    (values
                                      (lambda (i) i)
                                      (lambda (x) (add1 x))
                                      0
                                      (lambda (x) (< x 10))
                                      (lambda (v) #t)
                                      (lambda (x v) #t))))))

    ;; a cute example
    #;
    (let ()
      ;; generate infinte list of unique names
      (define-generator (machine-names)
                        (define letters "abcdefghijklmnopqrstuvwxyz")
                        (let loop ([len 0])
                          ;; generates strings of length num
                          (define-generator (generate num)
                                            (for ([letter (in-string 
letters)])
                                                 (if (= num 0)
                                                   (yield (string letter))
                                                   (for ([l2 (generate 
(- num 1))])
                                                        (yield 
(string-append (string letter) l2))))))
                          (for ([str (generate len)])
                               (yield str))
                          (loop (add1 len))))
      (for ([s (machine-names)]
            [j (in-range 0 1000)])
           (printf "~a: ~a\n" j s)))

    ))