summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorLinus Björnstam <linus.bjornstam@fastmail.se>2020-03-23 14:59:39 +0100
committerLudovic Courtès <ludo@gnu.org>2020-03-25 22:44:27 +0100
commit5f60eb6bb5af418b332101c69c88da639b117ae4 (patch)
tree421f6fbeb16bc6f098dcd788e30ebf0091d67f20 /module
parentf8f8986e4a5fad520e0f9e5e150b45178c0a7ed4 (diff)
downloadguile-5f60eb6bb5af418b332101c69c88da639b117ae4.tar.gz
Add SRFI-171 to guile
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>
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am3
-rw-r--r--module/srfi/srfi-171.scm457
-rw-r--r--module/srfi/srfi-171/gnu.scm65
-rw-r--r--module/srfi/srfi-171/meta.scm113
4 files changed, 638 insertions, 0 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 1d9d524cf..40b4b561a 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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 \
\
diff --git a/module/srfi/srfi-171.scm b/module/srfi/srfi-171.scm
new file mode 100644
index 000000000..eb2d4d4e5
--- /dev/null
+++ b/module/srfi/srfi-171.scm
@@ -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)))))
+
+
+
+
diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm
new file mode 100644
index 000000000..45a4e19af
--- /dev/null
+++ b/module/srfi/srfi-171/gnu.scm
@@ -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)))))))
diff --git a/module/srfi/srfi-171/meta.scm b/module/srfi/srfi-171/meta.scm
new file mode 100644
index 000000000..771f707ee
--- /dev/null
+++ b/module/srfi/srfi-171/meta.scm
@@ -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))))))
+