suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added `in-producer'.

Browse Source 
(Note that `test-generator' tests use quasiquote for the expected result).

svn: r15811
This commit is contained in:
Eli Barzilay 2009-08-27 09:15:52 +00:00
parent f63a9046af
commit ec9fc2571a
3 changed files with 123 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/scheme/private/for.ss
View File

@ -43,6 +43,7 @@
in-parallel
stop-before
stop-after
(rename *in-producer in-producer)
(rename *in-indexed in-indexed)
(rename *in-value in-value)
@ -651,6 +652,22 @@
poses
vals))))))))
(define (in-producer producer stop . more)
(make-do-sequence
(lambda ()
(values (if (null? more)
(lambda (_) (producer))
(lambda (_) (apply producer more)))
void
(void)
void
(if (procedure? stop)
(if (equal? 1 (procedure-arity stop))
(lambda (x) (not (stop x)))
(lambda xs (not (apply stop xs))))
(lambda (x) (not (eq? x stop))))
void))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; running sequences outside of a loop:
@ -1138,4 +1155,60 @@
[((id) (_ expr))
#'[(id)
(:do-in ([(id) expr])
#t () #t () #t #f ())]]))))
#t () #t () #t #f ())]])))
(define-sequence-syntax *in-producer
(lambda () #'in-producer)
(lambda (stx)
(syntax-case stx ()
[((id) (_ producer stop more ...))
(with-syntax ([(more* ...) (generate-temporaries #'(more ...))])
#'[(id)
(:do-in
;;outer bindings
([(producer*) producer] [(more*) more] ...
[(stop?) (let ([s stop])
(if (procedure? s) s (lambda (x) (eq? x s))))])
;; outer check
#t
;; loop bindings
()
;; pos check
#t
;; inner bindings
([(id) (producer* more* ...)])
;; pre guard
(not (stop? id))
;; post guard
#t
;; loop args
())])]
;; multiple-values version
[((id ...) (_ producer stop more ...))
(with-syntax ([(more* ...) (generate-temporaries #'(more ...))])
#'[(id ...)
(:do-in
;;outer bindings
([(producer*) producer] [(more*) more] ...
[(stop?) (let ([s stop])
(if (procedure? s)
s
(error 'in-producer
"stop condition for ~a, got: ~e"
"multiple values must be a predicate" s)))])
;; outer check
#t
;; loop bindings
()
;; pos check
#t
;; inner bindings
([(id ...) (producer* more* ...)])
;; pre guard
(not (stop? id ...))
;; post guard
#t
;; loop args
())])])))
)

10
collects/scribblings/reference/sequences.scrbl
View File

@ -166,6 +166,16 @@ its value from @scheme[hash] (as opposed to using @scheme[hash] directly
as a sequence to get the key and value as separate values for each
element).}
@defproc[(in-producer [producer procedure?] [stop any/c] [args any/c] ...)
sequence]{
Returns a sequence that contains values from sequential calls to
@scheme[producer]. @scheme[stop] identifies the value that marks the
end of the sequence --- this value is not included in the sequence.
@scheme[stop] can be a predicate or a value that is tested against the
results with @scheme[eq?]. Note that you must use a predicate function
if the stop value is itself a function, or if the @scheme[producer]
returns multiple values.}
@defproc[(in-value [v any/c]) sequence]{
Returns a sequence that produces a single value: @scheme[v]. This form
is mostly useful for @scheme[let]-like bindings in forms such as

64
collects/tests/mzscheme/for.ss
View File

@ -13,21 +13,21 @@
[((v2 ...) ...)
(apply map list (map syntax->list (syntax->list #'((v ...) ...))))])
#'(begin
(test '((v2 ...) ...) 'gen (for/list ([(id ...) gen])
(test `((v2 ...) ...) 'gen (for/list ([(id ...) gen])
(list id ...)))
(test-values '((v ...) ...) (lambda ()
(test-values `((v ...) ...) (lambda ()
(for/lists (id2 ...) ([(id ...) gen])
(values id ...))))
(test #t 'gen (for/and ([(id ...) gen])
(and (member (list id ...) '((v2 ...) ...)) #t)))
(and (member (list id ...) `((v2 ...) ...)) #t)))
(test (list (for/last ([(id ...) gen])
(list id ...)))
'gen (for/and ([(id ...) gen])
(member (list id ...) '((v2 ...) ...))))
(member (list id ...) `((v2 ...) ...))))
(test (for/first ([(id ...) gen])
(list id ...))
'gen (for/or ([(id ...) gen])
(car (member (list id ...) '((v2 ...) ...)))))
(car (member (list id ...) `((v2 ...) ...)))))
(void)))]))
(define-syntax test-generator
@ -35,45 +35,45 @@
[(_ [seq] gen) ; we assume that seq has at least 2 elements, and all are unique
(begin
;; Some tests specific to single-values:
(test 'seq 'gen (for/list ([i gen]) i))
(test 'seq 'gen (for/list ([i gen][b gen]) i))
(test 'seq 'gen (for/list ([i gen][b gen]) b))
(test 'seq 'gen (for*/list ([i gen][b '(#t)]) i))
(test (map (lambda (x) #t) 'seq) 'gen (for*/list ([i gen][b '(#t)]) b))
(test (append 'seq 'seq) 'gen (for*/list ([b '(#f #t)][i gen]) i))
(test (append 'seq 'seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i))
(test 'seq 'gen (let ([g gen]) (for/list ([i g]) i)))
(test 'seq 'gen (let ([r null])
(test `seq 'gen (for/list ([i gen]) i))
(test `seq 'gen (for/list ([i gen][b gen]) i))
(test `seq 'gen (for/list ([i gen][b gen]) b))
(test `seq 'gen (for*/list ([i gen][b '(#t)]) i))
(test (map (lambda (x) #t) `seq) 'gen (for*/list ([i gen][b '(#t)]) b))
(test (append `seq `seq) 'gen (for*/list ([b '(#f #t)][i gen]) i))
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i))
(test `seq 'gen (let ([g gen]) (for/list ([i g]) i)))
(test `seq 'gen (let ([r null])
(for ([i gen]) (set! r (cons i r)))
(reverse r)))
(test 'seq 'gen (reverse (for/fold ([a null]) ([i gen])
(test `seq 'gen (reverse (for/fold ([a null]) ([i gen])
(cons i a))))
(test 'seq 'gen (let-values ([(more? next) (sequence-generate gen)])
(test `seq 'gen (let-values ([(more? next) (sequence-generate gen)])
(let loop ()
(if (more?)
(cons (next) (loop))
null))))
(test-values '(seq seq) (lambda ()
null))))
(test-values `(seq seq) (lambda ()
(for/lists (r1 r2) ([id gen])
(values id id))))
(test (list (for/last ([i gen]) i)) 'gen (for/and ([i gen]) (member i 'seq)))
(test 'seq 'gen (for/or ([i gen]) (member i 'seq)))
(test (for/first ([i gen]) i) 'gen (for/or ([i gen]) (and (member i 'seq) i)))
(test #t 'gen (for/and ([(i k) (in-parallel gen 'seq)])
(test (list (for/last ([i gen]) i)) 'gen (for/and ([i gen]) (member i `seq)))
(test `seq 'gen (for/or ([i gen]) (member i `seq)))
(test (for/first ([i gen]) i) 'gen (for/or ([i gen]) (and (member i `seq) i)))
(test #t 'gen (for/and ([(i k) (in-parallel gen `seq)])
(equal? i k)))
(test #f 'gen (for/and ([i gen])
(member i (cdr (reverse 'seq)))))
(member i (cdr (reverse `seq)))))
(test #f 'gen (for/or ([i gen]) (equal? i 'something-else)))
(let ([count 0])
(test #t 'or (for/or ([i gen]) (set! count (add1 count)) #t))
(test 1 'count count)
(test #f 'or (for/or ([i gen]) (set! count (add1 count)) #f))
(test (+ 1 (length 'seq)) 'count count)
(test (+ 1 (length `seq)) 'count count)
(set! count 0)
(let ([second (for/last ([(i pos) (in-parallel gen (in-naturals))] #:when (< pos 2))
(set! count (add1 count))
i)])
(test second list-ref 'seq 1)
(test second list-ref `seq 1)
(test 2 values count)
(for ([i gen] #:when (equal? i second)) (set! count (add1 count)))
(for* ([i gen] #:when (equal? i second)) (set! count (add1 count)))
@ -161,6 +161,20 @@
(test-generator [(a b c) (0 1 2)] (in-indexed '(a b c)))
(test-generator [(1 2 3 4 5)]
(parameterize ([current-input-port (open-input-string "1 2 3\n4 5")])
(for/list ([i (in-producer read eof)]) i)))
(test-generator [(1 2 3 4 5)]
(for/list ([i (in-producer read eof (open-input-string "1 2 3\n4 5"))]) i))
(test-generator [("1 2 3" "4 5")]
(for/list ([i (in-producer read-line eof-object? (open-input-string "1 2 3\n4 5"))]) i))
(test-generator [((1 2) (3 4) (5 ,eof))]
(for/list ([(i j)
(in-producer (lambda (p) (values (read p) (read p)))
(lambda (x y) (and (eof-object? x) (eof-object? y)))
(open-input-string "1 2 3\n4 5"))])
(list i j)))
(test #hash((a . 1) (b . 2) (c . 3)) 'mk-hash
(for/hash ([v (in-naturals)]
[k '(a b c)])