mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add SRFI-171 to guile

Browse source 
This adds SRFI-171 (transducers) to guile.

The two guile-specific additions are powerful transducers which can be
used to generalize transducers like tsegment. They are hard to get
right, but powerful and useful enough to warrant inclusion.

 * doc/ref/srfi-modules.texi: added srfi-171 section
 * module/Makefile.am (SOURCES):
 * module/srfi/srfi-171.scm:
 * module/srfi/srfi-171/meta.scm: Add SRFI-171
 * module/srfi/srfi-171/gnu.scm: Add 2 guile-specific extensions.
 * test-suite/Makefile.am (SCM_TESTS):
 * test-suite/tests/srfi-171.test: Add tests.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Linus Björnstam 2020-03-23 14:59:39 +01:00 • committed by Ludovic Courtès
parent f8f8986e4a
commit 5f60eb6bb5
7 changed files with 1393 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

487
doc/ref/srfi-modules.texi
View file

@ -64,6 +64,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
* SRFI-171:: Transducers
@end menu
@ -5602,6 +5603,492 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
@cindex transducers
Some of the most common operations used in the Scheme language are those
transforming lists: map, filter, take and so on. They work well, are well
understood, and are used daily by most Scheme programmers. They are however not
general because they only work on lists, and they do not compose very well
since combining N of them builds @code{(- N 1)} intermediate lists.
Transducers are oblivious to what kind of process they are used in, and
are composable without building intermediate collections. This means we
can create a transducer that squares all even numbers:
@example
(compose (tfilter odd?) (tmap (lambda (x) (* x x))))
@end example
and reuse it with lists, vectors, or in just about any context where
data flows in one direction. We could use it as a processing step for
asynchronous channels, with an event framework as a pre-processing step,
or even in lazy contexts where you pass a lazy collection and a
transducer to a function and get a new lazy collection back.
The traditional Scheme approach of having collection-specific procedures
is not changed. We instead specify a general form of transformations
that complement these procedures. The benefits are obvious: a clear,
well-understood way of describing common transformations in a way that
is faster than just chaining the collection-specific counterparts. For
guile in particular this means a lot better GC performance.
Notice however that @code{(compose @dots{})} composes transducers
left-to-right, due to how transducers are initiated.
@menu
* SRFI-171 General Discussion:: General information about transducers
* SRFI-171 Applying Transducers:: Documentation of collection-specific forms
* SRFI-171 Reducers:: Reducers specified by the SRFI
* SRFI-171 Transducers:: Transducers specified by the SRFI
* SRFI-171 Helpers:: Utilities for writing your own transducers
@end menu
@node SRFI-171 General Discussion
@subsubsection SRFI-171 General Discussion
@cindex transducers discussion
@subheading The concept of reducers
The central part of transducers are 3-arity reducing procedures.
@itemize
@item
no arguments: Produces the identity of the reducer.
@item
(result-so-far): completion. Returns @code{result-so-far} either with or
without transforming it first.
@item
(result-so-far input) combines @code{result-so-far} and @code{input} to produce
a new @code{result-so-far}.
@end itemize
In the case of a summing @code{+} reducer, the reducer would produce, in
arity order: @code{0}, @code{result-so-far}, @code{(+ result-so-far
input)}. This happens to be exactly what the regular @code{+} does.
@subheading The concept of transducers
A transducer is a one-arity procedure that takes a reducer and produces a
reducing function that behaves as follows:
@itemize
@item
no arguments: calls reducer with no arguments (producing its identity)
@item
(result-so-far): Maybe transform the result-so-far and call reducer with it.
@item
(result-so-far input) Maybe do something to input and maybe call the
reducer with result-so-far and the maybe-transformed input.
@end itemize
A simple example is as following:
@example
(list-transduce (tfilter odd?)+ '(1 2 3 4 5)).
@end example
This first returns a transducer filtering all odd
elements, then it runs @code{+} without arguments to retrieve its
identity. It then starts the transduction by passing @code{+} to the
transducer returned by @code{(tfilter odd?)} which returns a reducing
function. It works not unlike reduce from SRFI 1, but also checks
whether one of the intermediate transducers returns a "reduced" value
(implemented as a SRFI 9 record), which means the reduction finished
early.
Because transducers compose and the final reduction is only executed in
the last step, composed transducers will not build any intermediate
result or collections. Although the normal way of thinking about
application of composed functions is right to left, due to how the
transduction is built it is applied left to right. @code{(compose
(tfilter odd?) (tmap sqrt))} will create a transducer that first filters
out any odd values and then computes the square root of the rest.
@subheading State
Even though transducers appear to be somewhat of a generalisation of
@code{map} and friends, this is not really true. Since transducers don't
know in which context they are being used, some transducers must keep
state where their collection-specific counterparts do not. The
transducers that keep state do so using hidden mutable state, and as
such all the caveats of mutation, parallelism, and multi-shot
continuations apply. Each transducer keeping state is clearly described
as doing so in the documentation.
@subheading Naming
Reducers exported from the transducers module are named as in their
SRFI-1 counterpart, but prepended with an r. Transducers also follow
that naming, but are prepended with a t.
@node SRFI-171 Applying Transducers
@subsubsection Applying Transducers
@cindex transducers applying
@deffn {Scheme Procedure} list-transduce xform f lst
@deffnx {Scheme Procedure} list-transduce xform f identity lst
Initialize the transducer @var{xform} by passing the reducer @var{f}
to it. If no identity is provided, @var{f} runs without arguments to
return the reducer identity. It then reduces over @var{lst} using the
identity as the seed.
If one of the transducers finishes early (such as @code{ttake} or
@code{tdrop}), it communicates this by returning a reduced value, which
in the guile implementation is just a value wrapped in a SRFI 9 record
type named ``reduced''. If such a value is returned by the transducer,
@code{list-transduce} must stop execution and return an unreduced value
immediately.
@end deffn
@deffn {Scheme Procedure} vector-transduce xform f vec
@deffnx {Scheme Procedure} vector-transduce xform f identity vec
@deffnx {Scheme Procedure} string-transduce xform f str
@deffnx {Scheme Procedure} string-transduce xform f identity str
@deffnx {Scheme Procedure} bytevector-u8-transduce xform f bv
@deffnx {Scheme Procedure} bytevector-u8-transduce xform f identity bv
@deffnx {Scheme Procedure} generator-transduce xform f gen
@deffnx {Scheme Procedure} generator-transduce xform f identity gen
Same as @code{list-transduce}, but for vectors, strings, u8-bytevectors
and SRFI-158-styled generators respectively.
@end deffn
@deffn {Scheme Procedure} port-transduce xform f reader
@deffnx {Scheme Procedure} port-transduce xform f reader port
@deffnx {Scheme Procedure} port-transduce xform f identity reader port
Same as @code{list-reduce} but for ports. Called without a port, it
reduces over the results of applying @var{(reader)} until the
EOF-object is returned, presumably to read from
@code{current-input-port}. With a port @var{reader} is applied to
@var{port} instead of without any arguments. If @var{identity} is
provided, that is used as the initial identity in the reduction.
@end deffn
@node SRFI-171 Reducers
@subsubsection Reducers
@cindex transducers reducers
@deffn {Scheme Procedure} rcons
a simple consing reducer. When called without values, it returns its
identity, @code{'()}. With one value, which will be a list, it reverses
the list (using @code{reverse!}). When called with two values, it conses
the second value to the first.
@example
(list-transduce (tmap (lambda (x) (+ x 1)) rcons (list 0 1 2 3))
@result{} (1 2 3 4)
@end example
@end deffn
@deffn {Scheme Procedure} reverse-rcons
same as rcons, but leaves the values in their reversed order.
@example
(list-transduce (tmap (lambda (x) (+ x 1))) reverse-rcons (list 0 1 2 3))
@result{} (4 3 2 1)
@end example
@end deffn
@deffn {Scheme Procedure} rany pred?
The reducer version of any. Returns @code{(reduced (pred? value))} if
any @code{(pred? value)} returns non-#f. The identity is #f.
@example
(list-transduce (tmap (lambda (x) (+ x 1))) (rany odd?) (list 1 3 5))
@result{} #f
(list-transduce (tmap (lambda (x) (+ x 1))) (rany odd?) (list 1 3 4 5))
@result{} #t
@end example
@end deffn
@deffn {Scheme Procedure} revery pred?
The reducer version of every. Stops the transduction and returns
@code{(reduced #f)} if any @code{(pred? value)} returns #f. If every
@code{(pred? value)} returns true, it returns the result of the last
invocation of @code{(pred? value)}. The identity is #t.
@example
(list-transduce
(tmap (lambda (x) (+ x 1)))
(revery (lambda (v) (if (odd? v) v #f)))
(list 2 4 6))
@result{} 7
(list-transduce (tmap (lambda (x) (+ x 1)) (revery odd?) (list 2 4 5 6))
@result{} #f
@end example
@end deffn
@deffn {Scheme Procedure} rcount
A simple counting reducer. Counts the values that pass through the
transduction.
@example
(list-transduce (tfilter odd?) rcount (list 1 2 3 4)) @result{} 2.
@end example
@end deffn
@node SRFI-171 Transducers
@subsubsection Transducers
@cindex transducers transducers
@deffn {Scheme Procedure} tmap proc
Returns a transducer that applies @var{proc} to all values. Stateless.
@end deffn
@deffn tfilter pred?
Returns a transducer that removes values for which @var{pred?} returns #f.
Stateless.
@end deffn
@deffn {Scheme Procedure} tremove pred?
Returns a transducer that removes values for which @var{pred?} returns non-#f.
Stateless
@end deffn
@deffn {Scheme Procedure} tfilter-map proc
The same as @code{(compose (tmap proc) (tfilter values))}. Stateless.
@end deffn
@deffn {Scheme Procedure} treplace mapping
The argument @var{mapping} is an association list (using @code{equal?}
to compare keys), a hash-table, a one-argument procedure taking one
argument and either producing that same argument or a replacement value.
Returns a transducer which checks for the presence of any value passed
through it in mapping. If a mapping is found, the value of that mapping
is returned, otherwise it just returns the original value.
Does not keep internal state, but modifying the mapping while it's in
use by treplace is an error.
@end deffn
@deffn {Scheme Procedure} tdrop n
Returns a transducer that discards the first @var{n} values.
Stateful.
@end deffn
@deffn {Scheme Procedure} ttake n
Returns a transducer that discards all values and stops the transduction
after the first @var{n} values have been let through. Any subsequent values
are ignored.
Stateful.
@end deffn
@deffn {Scheme Procedure} tdrop-while pred?
Returns a transducer that discards the the first values for which
@var{pred?} returns true.
Stateful.
@end deffn
@deffn {Scheme Procedure} ttake-while pred?
@deffnx {Scheme Procedure} ttake-while pred? retf
Returns a transducer that stops the transduction after @var{pred?} has
returned #f. Any subsequent values are ignored and the last successful
value is returned. @var{retf} is a function that gets called whenever
@var{pred?} returns false. The arguments passed are the result so far
and the input for which pred? returns @code{#f}. The default function is
@code{(lambda (result input) result)}.
Stateful.
@end deffn
@deffn {Scheme Procedure} tconcatenate
tconcatenate @emph{is} a transducer that concatenates the content of
each value (that must be a list) into the reduction.
@example
(list-transduce tconcatenate rcons '((1 2) (3 4 5) (6 (7 8) 9)))
@result{} (1 2 3 4 5 6 (7 8) 9)
@end example
@end deffn
@deffn {Scheme Procedure} tappend-map proc
The same as @code{(compose (tmap proc) tconcatenate)}.
@end deffn
@deffn {Scheme Procedure} tflatten
tflatten @emph{is} a transducer that flattens an input consisting of lists.
@example
(list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7 8) 9)
@result{} (1 2 3 4 5 6 7 8 9)
@end example
@end deffn
@deffn {Scheme Procedure} tdelete-neighbor-duplicates
@deffnx {Scheme Procedure} tdelete-neighbor-duplicates equality-predicate
Returns a transducer that removes any directly following duplicate
elements. The default @var{equality-predicate} is @code{equal?}.
Stateful.
@end deffn
@deffn {Scheme Procedure} tdelete-duplicates
@deffnx {Scheme Procedure} tdelete-duplicates equality-predicate
Returns a transducer that removes any subsequent duplicate elements
compared using @var{equality-predicate}. The default
@var{equality-predicate} is @code{equal?}.
Stateful.
@end deffn
@deffn {Scheme Procedure} tsegment n
Returns a transducer that groups @var{n} inputs in lists of @var{n}
elements. When the transduction stops, it flushes any remaining
collection, even if it contains fewer than @var{n} elements.
Stateful.
@end deffn
@deffn {Scheme Procedure} tpartition pred?
Returns a transducer that groups inputs in lists by whenever
@code{(pred? input)} changes value.
Stateful.
@end deffn
@deffn {Scheme Procedure} tadd-between value
Returns a transducer which interposes @var{value} between each value
and the next. This does not compose gracefully with transducers like
@code{ttake}, as you might end up ending the transduction on
@code{value}.
Stateful.
@end deffn
@deffn {Scheme Procedure} tenumerate
@deffnx {Scheme Procedure} tenumerate start
Returns a transducer that indexes values passed through it, starting at
@var{start}, which defaults to 0. The indexing is done through cons
pairs like @code{(index . input)}.
@example
(list-transduce (tenumerate 1) rcons (list 'first 'second 'third))
@result{} ((1 . first) (2 . second) (3 . third))
@end example
Stateful.
@end deffn
@deffn {Scheme Procedure} tlog
@deffnx {Scheme Procedure} tlog logger
Returns a transducer that can be used to log or print values and
results. The result of the @var{logger} procedure is discarded. The
default @var{logger} is @code{(lambda (result input) (write input)
(newline))}.
Stateless.
@end deffn
@subheading Guile-specific transducers
These transducers are available in the @code{(srfi srfi-171 gnu)}
library, and are provided outside the standard described by the SRFI-171
document.
@deffn {Scheme Procedure} tbatch reducer
@deffnx {Scheme Procedure} tbatch transducer reducer
A batching transducer that accumulates results using @var{reducer} or
@code{((transducer) reducer)} until it returns a reduced value. This can
be used to generalize something like @code{tsegment}:
@example
;; This behaves exactly like (tsegment 4).
(list-transduce (tbatch (ttake 4) rcons) rcons (iota 10))
@result {} ((0 1 2 3) (4 5 6 7) (8 9))
@end example
@end deffn
@deffn {Scheme Procedure} tfold reducer
@deffnx {Scheme Procedure} tfold reducer seed
A folding transducer that yields the result of @code{(reducer seed
value)}, saving it's result between iterations.
@example
(list-transduce (tfold +) rcons (iota 10))
@result{} (0 1 3 6 10 15 21 28 36 45)
@end example
@end deffn
@node SRFI-171 Helpers
@subsubsection Helper functions for writing transducers
@cindex transducers helpers
These functions are in the @code{(srfi srfi-171 meta)} module and are only
usable when you want to write your own transducers.
@deffn {Scheme Procedure} reduced value
Wraps a value in a @code{<reduced>} container, signalling that the
reduction should stop.
@end deffn
@deffn {Scheme Procedure} reduced? value
Returns #t if value is a @code{<reduced>} record.
@end deffn
@deffn {Scheme Procedure} unreduce reduced-container
Returns the value in reduced-container.
@end deffn
@deffn {Scheme Procedure} ensure-reduced value
Wraps value in a @code{<reduced>} container if it is not already reduced.
@end deffn
@deffn {Scheme Procedure} preserving-reduced reducer
Wraps @code{reducer} in another reducer that encapsulates any returned
reduced value in another reduced container. This is useful in places
where you re-use a reducer with [collection]-reduce. If the reducer
returns a reduced value, [collection]-reduce unwraps it. Unless handled,
this leads to the reduction continuing.
@end deffn
@deffn {Scheme Procedure} list-reduce f identity lst
The reducing function used internally by @code{list-transduce}. @var{f}
is a reducer as returned by a transducer. @var{identity} is the
identity (sometimes called "seed") of the reduction. @var{lst} is a
list. If @var{f} returns a reduced value, the reduction stops
immediately and the unreduced value is returned.
@end deffn
@deffn {Scheme Procedure} vector-reduce f identity vec
The vector version of list-reduce.
@end deffn
@deffn {Scheme Procedure} string-reduce f identity str
The string version of list-reduce.
@end deffn
@deffn {Scheme Procedure} bytevector-u8-reduce f identity bv
The bytevector-u8 version of list-reduce.
@end deffn
@deffn {Scheme Procedure} port-reduce f identity reader port
The port version of list-reducer. It reduces over port using reader
until reader returns the EOF object.
@end deffn
@deffn {Scheme Procedure} generator-reduce f identity gen
The port version of list-reduce. It reduces over @code{gen} until it
returns the EOF object
@end deffn
@c srfi-modules.texi ends here
@c Local Variables:

3
module/Makefile.am
View file

@ -312,6 +312,9 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
\
statprof.scm \
\

457
module/srfi/srfi-171.scm Normal file
View file

@ -0,0 +1,457 @@
;; Copyright (C) 2020 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (srfi srfi-171)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module ((srfi srfi-43) #:select (vector->list))
#:use-module ((srfi srfi-69) #:prefix srfi69:)
#:use-module ((rnrs hashtables) #:prefix rnrs:)
#:use-module (srfi srfi-171 meta)
#:export (rcons
reverse-rcons
rcount
rany
revery
list-transduce
vector-transduce
string-transduce
bytevector-u8-transduce
port-transduce
generator-transduce
tmap
tfilter
tremove
treplace
tfilter-map
tdrop
tdrop-while
ttake
ttake-while
tconcatenate
tappend-map
tdelete-neighbor-duplicates
tdelete-duplicates
tflatten
tsegment
tpartition
tadd-between
tenumerate
tlog))
(cond-expand-provide (current-module) '(srfi-171))
;; A placeholder for a unique "nothing".
(define nothing (list 'nothing))
(define (nothing? val)
(eq? val nothing))
;;; Reducing functions meant to be used at the end at the transducing process.
(define rcons
(case-lambda
"A transducer-friendly consing reducer with '() as identity."
(() '())
((lst) (reverse! lst))
((lst x) (cons x lst))))
(define reverse-rcons
(case-lambda
"A transducer-friendly consing reducer with '() as identity.
The resulting list is in reverse order."
(() '())
((lst) lst)
((lst x) (cons x lst))))
(define rcount
(case-lambda
"A counting reducer that counts any elements that made it through the
transduction.
@example
(transduce (tfilter odd?) tcount (list 1 2 3)) @result{} 2
@end example"
(() 0)
((result) result)
((result input)
(+ 1 result))))
(define (rany pred)
(case-lambda
"Return a reducer that tests input using @var{pred}. If any input satisfies
@var{pred}, return @code{(reduced value)}."
(() #f)
((result) result)
((result input)
(let ((test (pred input)))
(if test
(reduced test)
#f)))))
(define (revery pred)
(case-lambda
"Returns a reducer that tests input using @var{pred}. If any input satisfies
@var{pred}, it returns @code{(reduced #f)}."
(() #t)
((result) result)
((result input)
(let ((test (pred input)))
(if (and result test)
test
(reduced #f))))))
(define list-transduce
(case-lambda
((xform f coll)
(list-transduce xform f (f) coll))
((xform f init coll)
(let* ((xf (xform f))
(result (list-reduce xf init coll)))
(xf result)))))
(define vector-transduce
(case-lambda
((xform f coll)
(vector-transduce xform f (f) coll))
((xform f init coll)
(let* ((xf (xform f))
(result (vector-reduce xf init coll)))
(xf result)))))
(define string-transduce
(case-lambda
((xform f coll)
(string-transduce xform f (f) coll))
((xform f init coll)
(let* ((xf (xform f))
(result (string-reduce xf init coll)))
(xf result)))))
(define bytevector-u8-transduce
(case-lambda
((xform f coll)
(bytevector-u8-transduce xform f (f) coll))
((xform f init coll)
(let* ((xf (xform f))
(result (bytevector-u8-reduce xf init coll)))
(xf result)))))
(define port-transduce
(case-lambda
((xform f by)
(generator-transduce xform f by))
((xform f by port)
(port-transduce xform f (f) by port))
((xform f init by port)
(let* ((xf (xform f))
(result (port-reduce xf init by port)))
(xf result)))))
(define generator-transduce
(case-lambda
((xform f gen)
(generator-transduce xform f (f) gen))
((xform f init gen)
(let* ((xf (xform f))
(result (generator-reduce xf init gen)))
(xf result)))))
;;; Transducers
(define (tmap f)
(lambda (reducer)
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(reducer result (f input))))))
(define (tfilter pred)
(lambda (reducer)
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(if (pred input)
(reducer result input)
result)))))
(define (tremove pred)
(lambda (reducer)
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(if (not (pred input))
(reducer result input)
result)))))
(define (tfilter-map f)
(compose (tmap f) (tfilter values)))
(define (make-replacer map)
(cond
((list? map)
(lambda (x)
(match (assoc x map)
((_ . replacer) replacer)
(#f x))))
((srfi69:hash-table? map)
(lambda (x)
(srfi69:hash-table-ref/default map x x)))
((rnrs:hashtable? map)
(lambda (x)
(rnrs:hashtable-ref map x x)))
((hash-table? map)
(lambda (x)
(hash-ref map x x)))
((procedure? map) map)
(else
(error "Unsupported mapping in treplace" map))))
(define (treplace map)
"Return a transducer that searches for any input in @var{map}, which may
be a guile native hashtable, an R6RS hashtable, a srfi-69 hashtable, an alist
or a one-argument procedure taking one value and producing either the same
value or a replacement one. Alists and guile-native hashtbles compare keys
using @code{equal?} whereas the other mappings use whatever equality predicate
they were created with."
(tmap (make-replacer map)))
(define (tdrop n)
(lambda (reducer)
(let ((new-n (+ 1 n)))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(set! new-n (- new-n 1))
(if (positive? new-n)
result
(reducer result input)))))))
(define (tdrop-while pred)
(lambda (reducer)
(let ((drop? #t))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(if (and (pred input) drop?)
result
(begin
(set! drop? #f)
(reducer result input))))))))
(define (ttake n)
(lambda (reducer)
;; we need to reset new-n for every new transduction
(let ((new-n n))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(let ((result (if (positive? new-n)
(reducer result input)
result)))
(set! new-n (- new-n 1))
(if (not (positive? new-n))
(ensure-reduced result)
result)))))))
(define ttake-while
(case-lambda
((pred) (ttake-while pred (lambda (result input) result)))
((pred retf)
(lambda (reducer)
(let ((take? #t))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(if (and take? (pred input))
(reducer result input)
(begin
(set! take? #f)
(ensure-reduced (retf result input)))))))))))
(define (tconcatenate reducer)
(let ((preserving-reducer (preserving-reduced reducer)))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(list-reduce preserving-reducer result input)))))
(define (tappend-map f)
(compose (tmap f) tconcatenate))
(define (tflatten reducer)
"tflatten is a transducer that flattens any list passed through it.
@example
(list-transduce tflatten conj (list 1 2 (list 3 4 '(5 6) 7 8)))
@result{} (1 2 3 4 5 6 7 8)
@end example"
(case-lambda
(() '())
((result) (reducer result))
((result input)
(if (list? input)
(list-reduce (preserving-reduced (tflatten reducer)) result input)
(reducer result input)))))
(define tdelete-neighbor-duplicates
(case-lambda
(() (tdelete-neighbor-duplicates equal?))
((equality-pred?)
(lambda (reducer)
(let ((prev nothing))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(if (equality-pred? prev input)
result
(begin
(set! prev input)
(reducer result input))))))))))
(define* (tdelete-duplicates #:optional (equality-pred? equal?))
"tdelede-duplicates is a transducer that deletes any subsequent duplicate
elements. Comparisons is done using @var{equality-pred?}, which defaults
to @code{equal?}."
(lambda (reducer)
(let ((already-seen (srfi69:make-hash-table equality-pred?)))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(if (srfi69:hash-table-exists? already-seen input)
result
(begin
(srfi69:hash-table-set! already-seen input #t)
(reducer result input))))))))
(define (tsegment n)
"Return a transducer that partitions the input into
lists of @var{n} items. If the input stops it flushes any
accumulated state, which may be shorter than @var{n}."
(if (not (and (integer? n) (positive? n)))
(error "argument to tsegment must be a positive integer")
(lambda (reducer)
(let ((i 0)
(collect (make-vector n)))
(case-lambda
(() (reducer))
((result)
;; if there is anything collected when we are asked to quit
;; we flush it to the remaining transducers
(let ((result
(if (zero? i)
result
(reducer result (vector->list collect 0 i)))))
(set! i 0)
;; now finally, pass it downstreams
(if (reduced? result)
(reducer (unreduce result))
(reducer result))))
((result input)
(vector-set! collect i input)
(set! i (+ i 1))
;; If we have collected enough input we can pass it on downstream
(if (< i n)
result
(let ((next-input (vector->list collect 0 i)))
(set! i 0)
(reducer result next-input)))))))))
(define (tpartition f)
"Return a transducer that partitions any input by whenever
@code{(f input)} changes value. "
(lambda (reducer)
(let* ((prev nothing)
(collect '()))
(case-lambda
(() (reducer))
((result)
(let ((result
(if (null? collect)
result
(reducer result (reverse! collect)))))
(set! collect '())
(if (reduced? result)
(reducer (unreduce result))
(reducer result))))
((result input)
(let ((fout (f input)))
(cond
((or (equal? fout prev) (nothing? prev)) ; collect
(set! prev fout)
(set! collect (cons input collect))
result)
(else ; flush what we collected already to the reducer
(let ((next-input (reverse! collect)))
(set! prev fout)
(set! collect (list input))
(reducer result next-input))))))))))
(define (tadd-between elem)
"Return a transducer that interposes @var{elem} between each value pushed
through the transduction."
(lambda (reducer)
(let ((send-elem? #f))
(case-lambda
(() (reducer))
((result)
(reducer result))
((result input)
(if send-elem?
(let ((result (reducer result elem)))
(if (reduced? result)
result
(reducer result input)))
(begin
(set! send-elem? #t)
(reducer result input))))))))
(define* (tenumerate #:optional (n 0))
"Return a transducer that indexes every value passed through into a cons
pair as @code{(index . value)}. Starts at @var{n} which defaults to 0."
(lambda (reducer)
(let ((n n))
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(let ((input (cons n input)))
(set! n (+ n 1))
(reducer result input)))))))
(define* (tlog #:optional
(log-function (lambda (result input) (write input) (newline))))
(lambda (reducer)
(case-lambda
(() (reducer))
((result) (reducer result))
((result input)
(log-function result input)
(reducer result input)))))

65
module/srfi/srfi-171/gnu.scm Normal file
View file

@ -0,0 +1,65 @@
;; Copyright (C) 2020 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (srfi srfi-171 gnu)
#:use-module (srfi srfi-171)
#:use-module (srfi srfi-171 meta)
#:export (tbatch tfold))
(define tbatch
(case-lambda
((reducer)
(tbatch identity reducer))
((t r)
(lambda (reducer)
(let ((cur-reducer (t r))
(cur-state (r)))
(case-lambda
(() (reducer))
((result)
(if (equal? cur-state (cur-reducer))
(reducer result)
(let ((new-res (reducer result (cur-reducer cur-state))))
(if (reduced? new-res)
(reducer (unreduce new-res))
(reducer new-res)))))
((result value)
(let ((val (cur-reducer cur-state value)))
(cond
;; cur-reducer is done. Push value downstream
;; re-instantiate the state and the cur-reducer
((reduced? val)
(let ((unreduced-val (unreduce val)))
(set! cur-reducer (t r))
(set! cur-state (cur-reducer))
(reducer result (cur-reducer unreduced-val))))
(else
(set! cur-state val)
result))))))))))
(define* (tfold reducer #:optional (seed (reducer)))
(lambda (r)
(let ((state seed))
(case-lambda
(() (r))
((result) (r result))
((result value)
(set! state (reducer state value))
(if (reduced? state)
(reduced (reducer (unreduce state)))
(r result state)))))))

113
module/srfi/srfi-171/meta.scm Normal file
View file

@ -0,0 +1,113 @@
;; Copyright (C) 2020 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (srfi srfi-171 meta)
#:use-module (srfi srfi-9)
#:use-module ((rnrs bytevectors) #:select (bytevector-length bytevector-u8-ref))
#:export (reduced reduced?
unreduce
ensure-reduced
preserving-reduced
list-reduce
vector-reduce
string-reduce
bytevector-u8-reduce
port-reduce
generator-reduce))
;; A reduced value is stops the transduction.
(define-record-type <reduced>
(reduced val)
reduced?
(val unreduce))
(define (ensure-reduced x)
"Ensure that @var{x} is reduced"
(if (reduced? x)
x
(reduced x)))
;; helper function that wraps a reduced value twice since reducing functions (like list-reduce)
;; unwraps them. tconcatenate is a good example: it re-uses it's reducer on it's input using list-reduce.
;; If that reduction finishes early and returns a reduced value, list-reduce would "unreduce"
;; that value and try to continue the transducing process.
(define (preserving-reduced reducer)
(lambda (a b)
(let ((return (reducer a b)))
(if (reduced? return)
(reduced return)
return))))
;; This is where the magic tofu is cooked
(define (list-reduce f identity lst)
(if (null? lst)
identity
(let ((v (f identity (car lst))))
(if (reduced? v)
(unreduce v)
(list-reduce f v (cdr lst))))))
(define (vector-reduce f identity vec)
(let ((len (vector-length vec)))
(let loop ((i 0) (acc identity))
(if (= i len)
acc
(let ((acc (f acc (vector-ref vec i))))
(if (reduced? acc)
(unreduce acc)
(loop (+ i 1) acc)))))))
(define (string-reduce f identity str)
(let ((len (string-length str)))
(let loop ((i 0) (acc identity))
(if (= i len)
acc
(let ((acc (f acc (string-ref str i))))
(if (reduced? acc)
(unreduce acc)
(loop (+ i 1) acc)))))))
(define (bytevector-u8-reduce f identity vec)
(let ((len (bytevector-length vec)))
(let loop ((i 0) (acc identity))
(if (= i len)
acc
(let ((acc (f acc (bytevector-u8-ref vec i))))
(if (reduced? acc)
(unreduce acc)
(loop (+ i 1) acc)))))))
(define (port-reduce f identity reader port)
(let loop ((val (reader port)) (acc identity))
(if (eof-object? val)
acc
(let ((acc (f acc val)))
(if (reduced? acc)
(unreduce acc)
(loop (reader port) acc))))))
(define (generator-reduce f identity gen)
(let loop ((val (gen)) (acc identity))
(if (eof-object? val)
acc
(let ((acc (f acc val)))
(if (reduced? acc)
(unreduce acc)
(loop (gen) acc))))))

1
test-suite/Makefile.am
View file

@ -160,6 +160,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \

267
test-suite/tests/srfi-171.test Normal file
View file

@ -0,0 +1,267 @@
;; Copyright (C) 2020 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-171)
#:use-module (test-suite lib)
#:use-module (ice-9 hash-table)
#:use-module (srfi srfi-171)
#:use-module (srfi srfi-171 gnu)
#:use-module (rnrs bytevectors)
#:use-module ((rnrs hashtables) #:prefix rnrs:)
#:use-module ((srfi srfi-69) #:prefix srfi:))
(define (add1 x) (+ x 1))
(define numeric-list (iota 5))
(define numeric-vec (list->vector numeric-list))
(define bv (list->u8vector numeric-list))
(define test-string "0123456789abcdef")
(define list-of-chars (string->list test-string))
;; for testing all treplace variations
(define replace-alist '((1 . s) (2 . c) (3 . h) (4 . e) (5 . m)))
(define guile-hashtable (alist->hash-table replace-alist))
(define srfi69-hashtable (srfi:alist->hash-table replace-alist))
(define rnrs-hashtable (rnrs:make-eq-hashtable))
(rnrs:hashtable-set! rnrs-hashtable 1 's)
(rnrs:hashtable-set! rnrs-hashtable 2 'c)
(rnrs:hashtable-set! rnrs-hashtable 3 'h)
(rnrs:hashtable-set! rnrs-hashtable 4 'e)
(rnrs:hashtable-set! rnrs-hashtable 5 'm)
(define (replace-function val)
(case val
((1) 's)
((2) 'c)
((3) 'h)
((4) 'e)
((5) 'm)
(else val)))
;; Test procedures for port-transduce
;; broken out to properly close port
(define (port-transduce-test)
(let* ((port (open-input-string "0 1 2 3 4"))
(res (equal? 15 (port-transduce (tmap add1) + read
(open-input-string "0 1 2 3 4")))))
(close-port port)
res))
(define (port-transduce-with-identity-test)
(let* ((port (open-input-string "0 1 2 3 4"))
(res (equal? 15 (port-transduce (tmap add1)
+
0
read
(open-input-string "0 1 2 3 4")))))
(close-port port)
res))
(with-test-prefix "transducers"
(pass-if "tmap" (equal? '(1 2 3 4 5) (list-transduce (tmap add1)
rcons
numeric-list)))
(pass-if "tfilter" (equal? '(0 2 4) (list-transduce (tfilter even?)
rcons
numeric-list)))
(pass-if "tfilter+tmap" (equal?
'(1 3 5)
(list-transduce (compose (tfilter even?) (tmap add1))
rcons
numeric-list)))
(pass-if "tfilter-map"
(equal? '(1 3 5)
(list-transduce (tfilter-map
(lambda (x)
(if (even? x)
(+ x 1)
#f)))
rcons numeric-list)))
(pass-if "tremove"
(equal? (list-transduce (tremove char-alphabetic?)
rcount
list-of-chars)
(string-transduce (tremove char-alphabetic?)
rcount
test-string)))
(pass-if "treplace with alist"
(equal? '(s c h e m e r o c k s)
(list-transduce (treplace replace-alist)
rcons
'(1 2 3 4 5 4 r o c k s) )))
(pass-if "treplace with replace-function"
(equal? '(s c h e m e r o c k s)
(list-transduce (treplace replace-function)
rcons
'(1 2 3 4 5 4 r o c k s))))
(pass-if "treplace with guile hash-table"
(equal? '(s c h e m e r o c k s)
(list-transduce (treplace guile-hashtable)
rcons
'(1 2 3 4 5 4 r o c k s))))
(pass-if "treplace with srfi-69 hash-table"
(equal? '(s c h e m e r o c k s)
(list-transduce (treplace srfi69-hashtable)
rcons
'(1 2 3 4 5 4 r o c k s))))
(pass-if "treplace with rnrs hash-table"
(equal? '(s c h e m e r o c k s)
(list-transduce (treplace rnrs-hashtable)
rcons
'(1 2 3 4 5 4 r o c k s))))
(pass-if "ttake"
(equal? 6 (list-transduce (ttake 4) + numeric-list)))
(pass-if "tdrop"
(equal? 7 (list-transduce (tdrop 3) + numeric-list)))
(pass-if "tdrop-while"
(equal? '(3 4)
(list-transduce (tdrop-while (lambda (x) (< x 3)))
rcons
numeric-list)))
(pass-if "ttake-while"
(equal? '(0 1 2)
(list-transduce (ttake-while (lambda (x) (< x 3)))
rcons
numeric-list)))
(pass-if "tconcatenate"
(equal? '(0 1 2 3 4) (list-transduce tconcatenate
rcons
'((0 1) (2 3) (4)))))
(pass-if "tappend-map"
(equal? '(1 2 2 4 3 6)
(list-transduce (tappend-map (lambda (x) (list x (* x 2))))
rcons
'(1 2 3))))
(pass-if "tdelete-neighbor-duplicates"
(equal? '(1 2 1 2 3)
(list-transduce (tdelete-neighbor-duplicates)
rcons
'(1 1 1 2 2 1 2 3 3))))
(pass-if "tdelete-neighbor-duplicates with equality predicate"
(equal? '(a b c "hej" "hej")
(list-transduce (tdelete-neighbor-duplicates eq?)
rcons
(list 'a 'a 'b 'c 'c "hej" (string #\h #\e #\j)))))
(pass-if "tdelete-duplicates"
(equal? '(1 2 3 4)
(list-transduce (tdelete-duplicates)
rcons
'(1 1 2 1 2 3 3 1 2 3 4))))
(pass-if "tdelete-duplicates with predicate"
(equal? '("hej" "hopp")
(list-transduce (tdelete-duplicates string-ci=?)
rcons
(list "hej" "HEJ" "hopp" "HOPP" "heJ"))))
(pass-if "tflatten"
(equal? '(1 2 3 4 5 6 7 8 9)
(list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7) 8 (9)))))
(pass-if "tpartition"
(equal? '((1 1 1 1) (2 2 2 2) (3 3 3) (4 4 4 4))
(list-transduce (tpartition even?)
rcons
'(1 1 1 1 2 2 2 2 3 3 3 4 4 4 4))))
(pass-if "tsegment"
(equal? '((0 1) (2 3) (4))
(vector-transduce (tsegment 2) rcons numeric-vec)))
(pass-if "tadd-between"
(equal? '(0 and 1 and 2 and 3 and 4)
(list-transduce (tadd-between 'and) rcons numeric-list)))
(pass-if "tenumerate"
(equal? '((-1 . 0) (0 . 1) (1 . 2) (2 . 3) (3 . 4))
(list-transduce (tenumerate (- 1)) rcons numeric-list)))
(pass-if "tbatch"
(equal?
'((0 1) (2 3) (4))
(list-transduce (tbatch (ttake 2) rcons) rcons numeric-list)))
(pass-if "tfold"
(equal?
'(0 1 3 6 10)
(list-transduce (tfold +) rcons numeric-list))))
(with-test-prefix "x-transduce"
(pass-if "list-transduce"
(equal? 15 (list-transduce (tmap add1) + numeric-list)))
(pass-if "list-transduce with identity"
(equal? 15 (list-transduce (tmap add1) + 0 numeric-list)))
(pass-if "vector-transduce"
(equal? 15 (vector-transduce (tmap add1) + numeric-vec)))
(pass-if "vector-transduce with identity"
(equal? 15
(vector-transduce (tmap add1) + 0 numeric-vec)))
(pass-if "port-transduce" (port-transduce-test))
(pass-if "port-transduce with identity" (port-transduce-with-identity-test))
;; Converts each numeric char to it's corresponding integer and sums them.
(pass-if "string-transduce"
(equal?
15
(string-transduce (tmap (lambda (x) (- (char->integer x) 47))) + "01234")))
(pass-if "string-transduce with identity"
(equal?
15
(string-transduce (tmap (lambda (x) (- (char->integer x) 47)))
+
0
"01234")))
(pass-if "generator-transduce"
(equal?
'(1 2 3)
(parameterize ((current-input-port (open-input-string "1 2 3")))
(generator-transduce (tmap (lambda (x) x)) rcons read))))
(pass-if "generator-transduce with identity"
(equal?
'(1 2 3)
(parameterize ((current-input-port (open-input-string "1 2 3")))
(generator-transduce (tmap (lambda (x) x)) rcons '() read))))
(pass-if "bytevector-u8-transduce"
(equal? 15 (bytevector-u8-transduce (tmap add1) + bv)))
(pass-if "bytevector-u8-transduce with identity"
(equal? 15 (bytevector-u8-transduce (tmap add1) + 0 bv))))