* [PATCH] Add srfi-171 to guile
@ 2019-12-22 14:55 Linus Björnstam
2019-12-22 20:45 ` Linus Björnstam
2020-01-05 11:30 ` Andy Wingo
0 siblings, 2 replies; 9+ messages in thread
From: Linus Björnstam @ 2019-12-22 14:55 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 531 bytes --]
Hi there!
This is a patch to add srfi-171 (transducers) to guile.
It adds the srfi implementation, a guile-specific extension (tfold and tbatch which can be used to generalize things like tsegment), documentation (the whole srfi document plus additions into srfi-modules.texi) and tests.
I have built it successfully on the latest master. This would be my first ever commit to a project I did not start myself, with the added bonus that I have no idea of how git works. Be kind :)
Happy holidays!
Linus Björnstam
[-- Attachment #2: 0001-Added-srfi-171-to-guile-under-the-module-name-srfi-s.patch --]
[-- Type: application/octet-stream, Size: 28978 bytes --]
From 7e8d3b22ba5f814c40dbb5ab616a318c0cdc2f3e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
Date: Sun, 22 Dec 2019 15:38:34 +0100
Subject: [PATCH 1/2] Added srfi-171 to guile under the module name (srfi
srfi-171).
For more info, read the SRFI document: https://srfi.schemers.org/srfi-171/srfi-171.html
---
module/srfi/srfi-171.scm | 498 +++++++++++++++++++++++++++++++++
module/srfi/srfi-171/gnu.scm | 49 ++++
module/srfi/srfi-171/meta.scm | 115 ++++++++
test-suite/tests/srfi-171.test | 195 +++++++++++++
4 files changed, 857 insertions(+)
create mode 100644 module/srfi/srfi-171.scm
create mode 100644 module/srfi/srfi-171/gnu.scm
create mode 100644 module/srfi/srfi-171/meta.scm
create mode 100644 test-suite/tests/srfi-171.test
diff --git a/module/srfi/srfi-171.scm b/module/srfi/srfi-171.scm
new file mode 100644
index 000000000..7e8dc603f
--- /dev/null
+++ b/module/srfi/srfi-171.scm
@@ -0,0 +1,498 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2019 Linus Björnstam
+;;
+;; You may use this code under either the license in the SRFI document or the
+;; license below.
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; This module name is guile-specific. The correct module name is of course
+;; (srfi 171)
+(define-module (srfi srfi-171)
+ #:declarative? #t
+ #: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))
+
+
+
+;; A special value to be used as a placeholder where no value has been set and #f
+;; doesn't cut it. Not exported.
+
+(define-record-type <nothing>
+ (make-nothing)
+ nothing?)
+(define nothing (make-nothing))
+
+
+;; helper function which ensures x is reduced.
+(define (ensure-reduced x)
+ (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 f)
+ (lambda (a b)
+ (let ((return (f a b)))
+ (if (reduced? return)
+ (reduced return)
+ return))))
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Reducing functions meant to be used at the end at the transducing
+;; process. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; a transducer-friendly cons with the empty list as identity
+(define rcons
+ (case-lambda
+ (() '())
+ ((lst) (reverse! lst))
+ ((lst x) (cons x lst))))
+
+
+(define reverse-rcons
+ (case-lambda
+ (() '())
+ ((lst) lst)
+ ((lst x) (cons x lst))))
+
+
+;; Use this as the f in transduce to count the amount of elements passed through.
+;; (transduce (tfilter odd?) tcount (list 1 2 3)) => 2
+(define rcount
+ (case-lambda
+ (() 0)
+ ((result) result)
+ ((result input)
+ (+ 1 result))))
+
+
+;; These two take a predicate and returns reducing functions that behave
+;; like any and every from srfi-1
+(define (rany pred)
+ (case-lambda
+ (() #f)
+ ((result) result)
+ ((result input)
+ (let ((test (pred input)))
+ (if test
+ (reduced test)
+ #f)))))
+
+
+(define (revery pred)
+ (case-lambda
+ (() #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)
+ (let ((replacer? (assoc x map)))
+ (if replacer?
+ (cdr replacer?)
+ 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))))
+
+;; For alists and guile's native hash tables, compare using equal?.
+;; For r6rs and srfi69 hashtables, use whatever the hash table has configured.
+(define (treplace map)
+ (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))
+
+
+
+;; Flattens everything and passes each value through the reducer
+;; (list-transduce tflatten conj (list 1 2 (list 3 4 '(5 6) 7 8))) => (1 2 3 4 5 6 7 8)
+(define tflatten
+ (lambda (reducer)
+ (case-lambda
+ (() '())
+ ((result) (reducer result))
+ ((result input)
+ (if (list? input)
+ (list-reduce (preserving-reduced (tflatten reducer)) result input)
+ (reducer result input))))))
+
+
+
+;; removes duplicate consecutive elements
+(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))))))))))
+
+
+;; Deletes all duplicates that passes through.
+(define tdelete-duplicates
+ (case-lambda
+ (() (tdelete-duplicates equal?))
+ ((equality-pred?)
+ (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))))))))))
+
+;; Partitions the input into lists of N items. If the input stops it flushes whatever
+;; it has collected, which may be shorter than n.
+;; I am not sure about the correctness about this. It seems to work.
+(define (tsegment 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
+ (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)))))))))
+
+
+;; I am not sure about the correctness of this. It seems to work.
+;; we could maybe make it faster?
+(define (tpartition f)
+ (lambda (reducer)
+ (let* ((prev nothing)
+ (collect '()))
+ (case-lambda
+ (() (reducer))
+ ((result)
+ (let ((result
+ (if (null? collect)
+ result
+ (reducer result (reverse! collect)))))
+ (set! collect '())
+ (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))))))))))
+
+
+;; Interposes element between each value pushed through the transduction.
+(define (tadd-between elem)
+ (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))))))))
+
+
+;; indexes every value passed through in a cons pair as in (index . value). By default starts at 0
+(define tenumerate
+ (case-lambda
+ (() (tenumerate 0))
+ ((n)
+ (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
+ (case-lambda
+ (() (tlog (lambda (result input) (write input) (newline))))
+ ((log-function)
+ (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..9aa8ab28e
--- /dev/null
+++ b/module/srfi/srfi-171/gnu.scm
@@ -0,0 +1,49 @@
+(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..dd1fd06c4
--- /dev/null
+++ b/module/srfi/srfi-171/meta.scm
@@ -0,0 +1,115 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2019 Linus Björnstam
+;;
+;; You may use this code under either the license in the SRFI document or the
+;; license below.
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; This module name is guile-specific. The correct name is of course
+;; (srfi 171 meta)
+(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))
+
+
+;; helper function which ensures x is reduced.
+(define (ensure-reduced x)
+ (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))))))
+
+
diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
new file mode 100644
index 000000000..c6d574af2
--- /dev/null
+++ b/test-suite/tests/srfi-171.test
@@ -0,0 +1,195 @@
+;; TODO: test all transducers that take an equality predicate
+;; TODO: test treplace with all kinds of hash tables
+
+(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))))
--
2.24.1
[-- Attachment #3: 0002-Added-documentation-and-tests-for-srfi-171.patch --]
[-- Type: application/octet-stream, Size: 19325 bytes --]
From 39be4808f5921a716916de6f4db03990412f2518 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
Date: Sun, 22 Dec 2019 15:39:35 +0100
Subject: [PATCH 2/2] Added documentation and tests for srfi-171.
* doc/ref/srfi-modules.texi - Adapted and added the srfi document to the
guile srfi documentation
* module/Makefile.am - Added the srfi files for compilation
* test-suite/Makefile.am - Added the srfi-171.test to the test suite.
---
doc/ref/srfi-modules.texi | 399 ++++++++++++++++++++++++++++++++++++++
module/Makefile.am | 3 +
test-suite/Makefile.am | 1 +
3 files changed, 403 insertions(+)
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8f5b643c6..fbdfe0079 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -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,404 @@ 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: @code{(compose (tfilter odd?) (tmap (lambda (x) (* x x))))} 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 functions.
+
+@itemize @bullet
+@item
+(): Produce an identity
+
+@item
+(result-so-far): completion. If you have nothing to do, then just return the result so far
+
+@item
+(result-so-far input) do whatever you like to the input and produce a new 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 function that takes a reducer and produces a reducing function that behaves as follows:
+
+@itemize @bullet
+@item
+(): 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: @code{ (list-transduce (tfilter odd?) + '(1 2 3 4 5))}. 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 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
+ Initializes the transducer @code{xform} by passing the reducer @code{f} to it. If no identity is provided, @code{f} is run without arguments to return the reducer identity. It then reduces over @code{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 sample 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 @code{(reader)} until the EOF-object is returned, presumably to read from @code{current-input-port}. With a port @code{reader} is applied to @code{port} instead of without any arguments. If an @code{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 @code{proc} to all values. Stateless.
+@end deffn
+
+
+@deffn tfilter pred?
+Returns a transducer that removes values for which @code{pred?} returns #f.
+
+Stateless.
+@end deffn
+
+
+@deffn {Scheme Procedure} tremove pred?
+Returns a transducer that removes values for which @code{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 @code{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 n values.
+
+Stateful.
+@end deffn
+
+
+@deffn {Scheme Procedure} ttake n
+Returns a transducer that discards all values and stops the transduction after the first 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 @code{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 @code{pred?} has returned #f. Any subsequent values are ignored and the last successful value is returned. @code{retf} is a function that gets called whenever @code{pred?} returns false. The arguments passed are the result so far and the input for which pred? returns #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))) => (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 @code{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 @code{equality-predicate}. The default @code{equality-predicate} is @code{equal?}.
+
+Stateful.
+@end deffn
+
+
+@deffn {Scheme Procedure} tsegment n
+
+Returns a transducer that groups @code{n} inputs in lists of @code{n} elements. When the transduction stops, it flushes any remaining collection, even if it contains fewer than @code{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 @code{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 @code{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 @code{logger} procedure is discarded. The default @code{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 @code{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 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}. @code{f} is a reducer as returned by a transducer. @code{identity} is the identity (sometimes called "seed") of the reduction. @code{lst} is a list. If @code{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:
diff --git a/module/Makefile.am b/module/Makefile.am
index c6dff76e3..57d88b0cd 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -311,6 +311,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/test-suite/Makefile.am b/test-suite/Makefile.am
index 3810197e2..cafa5c92b 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -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 \
--
2.24.1
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2019-12-22 14:55 [PATCH] Add srfi-171 to guile Linus Björnstam
@ 2019-12-22 20:45 ` Linus Björnstam
2020-01-05 11:30 ` Andy Wingo
1 sibling, 0 replies; 9+ messages in thread
From: Linus Björnstam @ 2019-12-22 20:45 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 899 bytes --]
I forgot the copyright!
All the papers are in order with the FSF for the copyright assignment.
--
Linus Björnstam
On Sun, 22 Dec 2019, at 15:55, Linus Björnstam wrote:
> Hi there!
>
> This is a patch to add srfi-171 (transducers) to guile.
>
> It adds the srfi implementation, a guile-specific extension (tfold and
> tbatch which can be used to generalize things like tsegment),
> documentation (the whole srfi document plus additions into
> srfi-modules.texi) and tests.
>
> I have built it successfully on the latest master. This would be my
> first ever commit to a project I did not start myself, with the added
> bonus that I have no idea of how git works. Be kind :)
>
> Happy holidays!
> Linus Björnstam
> Attachments:
> * 0001-Added-srfi-171-to-guile-under-the-module-name-srfi-s.patch
> * 0002-Added-documentation-and-tests-for-srfi-171.patch
[-- Attachment #2: 0001-Added-proper-copyright-to-srfi-171.patch --]
[-- Type: application/octet-stream, Size: 6230 bytes --]
From 12038917c239874baae4baee710419ea2888a86c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
Date: Sun, 22 Dec 2019 21:42:01 +0100
Subject: [PATCH] Added proper copyright to srfi-171
---
module/srfi/srfi-171.scm | 25 +++++++++++++++----------
module/srfi/srfi-171/gnu.scm | 16 ++++++++++++++++
module/srfi/srfi-171/meta.scm | 24 ++++++++++++++----------
test-suite/tests/srfi-171.test | 17 +++++++++++++++--
4 files changed, 60 insertions(+), 22 deletions(-)
diff --git a/module/srfi/srfi-171.scm b/module/srfi/srfi-171.scm
index 7e8dc603f..a2914d7a9 100644
--- a/module/srfi/srfi-171.scm
+++ b/module/srfi/srfi-171.scm
@@ -1,14 +1,19 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Copyright 2019 Linus Björnstam
+;; Copyright (C) 2019 Free Software Foundation, Inc.
;;
-;; You may use this code under either the license in the SRFI document or the
-;; license below.
-;;
-;; Permission to use, copy, modify, and/or distribute this software for any
-;; purpose with or without fee is hereby granted, provided that the above
-;; copyright notice and this permission notice appear in all source copies.
-;; The software is provided "as is", without any express or implied warranties.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
+
;; This module name is guile-specific. The correct module name is of course
diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm
index 9aa8ab28e..db4ce76a0 100644
--- a/module/srfi/srfi-171/gnu.scm
+++ b/module/srfi/srfi-171/gnu.scm
@@ -1,3 +1,19 @@
+;; Copyright (C) 2019 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)
diff --git a/module/srfi/srfi-171/meta.scm b/module/srfi/srfi-171/meta.scm
index dd1fd06c4..8f369ef99 100644
--- a/module/srfi/srfi-171/meta.scm
+++ b/module/srfi/srfi-171/meta.scm
@@ -1,14 +1,18 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Copyright 2019 Linus Björnstam
+;; Copyright (C) 2019 Free Software Foundation, Inc.
;;
-;; You may use this code under either the license in the SRFI document or the
-;; license below.
-;;
-;; Permission to use, copy, modify, and/or distribute this software for any
-;; purpose with or without fee is hereby granted, provided that the above
-;; copyright notice and this permission notice appear in all source copies.
-;; The software is provided "as is", without any express or implied warranties.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
;; This module name is guile-specific. The correct name is of course
diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
index c6d574af2..f07941f20 100644
--- a/test-suite/tests/srfi-171.test
+++ b/test-suite/tests/srfi-171.test
@@ -1,5 +1,18 @@
-;; TODO: test all transducers that take an equality predicate
-;; TODO: test treplace with all kinds of hash tables
+;; Copyright (C) 2019 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)
--
2.24.1
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2019-12-22 14:55 [PATCH] Add srfi-171 to guile Linus Björnstam
2019-12-22 20:45 ` Linus Björnstam
@ 2020-01-05 11:30 ` Andy Wingo
2020-01-05 13:34 ` Linus Björnstam
2020-01-16 19:52 ` Linus Björnstam
1 sibling, 2 replies; 9+ messages in thread
From: Andy Wingo @ 2020-01-05 11:30 UTC (permalink / raw)
To: Linus Björnstam; +Cc: guile-devel
Hi :)
Since this is a final SRFI I think there's no problem getting it in.
Some formatting notes follow; since it's your first Guile patch I'm a
bit verbose :) Probably this will miss 3.0.0 but make 3.0.1, FWIW.
On Sun 22 Dec 2019 15:55, Linus Björnstam <linus.bjornstam@veryfast.biz> writes:
> From 7e8d3b22ba5f814c40dbb5ab616a318c0cdc2f3e Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> Date: Sun, 22 Dec 2019 15:38:34 +0100
> Subject: [PATCH 1/2] Added srfi-171 to guile under the module name (srfi
> srfi-171).
>
> For more info, read the SRFI document: https://srfi.schemers.org/srfi-171/srfi-171.html
Needs a note per-file; see other commit log messages. Also please wrap
to 72 characters.
> --- /dev/null
> +++ b/module/srfi/srfi-171.scm
> @@ -0,0 +1,498 @@
> +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> +;; Copyright 2019 Linus Bj.rnstam
> +;;
I think you've assigned copyright so this can have the standard Guile
copyright block, right?
> +;; This module name is guile-specific. The correct module name is of course
> +;; (srfi 171)
I don't think it's right to say there is a "correct" name. R6RS, R7RS,
and Guile have different naming conventions for SRFI modules and that's
OK.
The style in Guile is generally that block comments like this should be
complete sentences, starting with capital letters and including
terminating punctuation. Generally we do two spaces after periods,
also.
> +(define-module (srfi srfi-171)
> + #:declarative? #t
> + #: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
Better to put rcons on its own line so that other exports are also
aligned with the open paren.
> +;; A special value to be used as a placeholder where no value has been set and #f
> +;; doesn't cut it. Not exported.
> +
> +(define-record-type <nothing>
> + (make-nothing)
> + nothing?)
> +(define nothing (make-nothing))
Note that this can be somewhat cheaper as:
(define nothing (list 'nothing))
(define (nothing? x) (eq? x nothing))
> +;; helper function which ensures x is reduced.
Capitalize. FWIW, better done as a docstring:
(define (ensure-reduced x)
"Ensure that @var{x} is reduced."
...)
> +;; 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.
Capitalize and limit to 80 characters wide.
> +(define (preserving-reduced f)
> + (lambda (a b)
> + (let ((return (f a b)))
> + (if (reduced? return)
> + (reduced return)
> + return))))
> +
> +
> +
> +
Generally, put one blank line between functions. Two lines can be
between sections. Four is too much :)
> +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> +;; Reducing functions meant to be used at the end at the transducing
> +;; process. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
This is a fairly non-standard comment style, FWIW; consider just
prefixing with ";;;".
> +;; a transducer-friendly cons with the empty list as identity
> +(define rcons
> + (case-lambda
Similar comment regarding docstrings
> +;; Use this as the f in transduce to count the amount of elements passed through.
> +;; (transduce (tfilter odd?) tcount (list 1 2 3)) => 2
80 characters, and the example can go in an @example if you like:
(define rcount
(case-lambda
"A transducer that counts the number of elements passing through. \
@example
(transduce (tfilter odd?) tcount (list 1 2 3)) @result{} 2
@end example"
...))
> +(define (make-replacer map)
> + (cond
> + ((list? map)
> + (lambda (x)
> + (let ((replacer? (assoc x map)))
> + (if replacer?
> + (cdr replacer?)
> + x))))
I generally find this sort of thing better with (ice-9 match):
(match (assoc x map)
((x . replacer) replacer)
(#f x))
> +;; Flattens everything and passes each value through the reducer
> +;; (list-transduce tflatten conj (list 1 2 (list 3 4 '(5 6) 7 8))) => (1 2 3 4 5 6 7 8)
80 chars
> +;; I am not sure about the correctness of this. It seems to work.
> +;; we could maybe make it faster?
> +(define (tpartition f)
How could you know about the correctness? Probably a good idea to do
what it takes to be sure and then remove the comment. Regarding speed,
I would remove the comment, if it's slow then people can work on it.
Note that in general comments shouldn't be from a first-person
perspective, because the code will be maintained as part of Guile, not
necessarily by the author.
> diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm
> new file mode 100644
> index 000000000..9aa8ab28e
> --- /dev/null
> +++ b/module/srfi/srfi-171/gnu.scm
> @@ -0,0 +1,49 @@
> +(define-module (srfi srfi-171 gnu)
Needs a copyright header
> diff --git a/module/srfi/srfi-171/meta.scm b/module/srfi/srfi-171/meta.scm
> new file mode 100644
> index 000000000..dd1fd06c4
> --- /dev/null
> +++ b/module/srfi/srfi-171/meta.scm
> @@ -0,0 +1,115 @@
> +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> +;; Copyright 2019 Linus Bj.rnstam
Probably should be a Guile copyright header
> diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
> new file mode 100644
> index 000000000..c6d574af2
> --- /dev/null
> +++ b/test-suite/tests/srfi-171.test
> @@ -0,0 +1,195 @@
> +;; TODO: test all transducers that take an equality predicate
> +;; TODO: test treplace with all kinds of hash tables
> +
> +(define-module (test-srfi-171)
Needs a copyright header
> From 39be4808f5921a716916de6f4db03990412f2518 Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> Date: Sun, 22 Dec 2019 15:39:35 +0100
> Subject: [PATCH 2/2] Added documentation and tests for srfi-171.
>
> * doc/ref/srfi-modules.texi - Adapted and added the srfi document to the
> guile srfi documentation
> * module/Makefile.am - Added the srfi files for compilation
> * test-suite/Makefile.am - Added the srfi-171.test to the test suite.
Thanks for the per-file notes :)
FWIW the general format would be like:
* doc/ref/srfi-modules.texi:
* module/Makefile.am (SOURCES):
* test-suite/Makefile.am (SCM_TESTS): Add srfi-171.
I.e. colons after the file, and the changed function or variable in
parens, and then the tense is present: it describes the change. See
https://www.gnu.org/prep/standards/html_node/Change-Logs.html (though we
adapt it for Git).
> +@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.
Limit to 80 chars please. In Emacs you'd do M-q to do this.
> +@itemize @bullet
Probably you can leave off @bullet.
> +@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
Probably better style to have just one empty line. I would also break
the last line.
Cheers,
Andy
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2020-01-05 11:30 ` Andy Wingo
@ 2020-01-05 13:34 ` Linus Björnstam
2020-01-16 19:52 ` Linus Björnstam
1 sibling, 0 replies; 9+ messages in thread
From: Linus Björnstam @ 2020-01-05 13:34 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
Thanks for taking time to review it!
I will make a new patch with all your proposed changes.
Don't mind the correctness comments, btw. They are a rest from the first successful implementation when I had a less clear mental model of how transducers worked. I know how to verify and test that they work as they should.
Regarding the copyright block I was a bit too trigger happy. I completely forgot!
I have loads at work right now (2 weeks of modern music cd recording. Fun times!), but so will make sure to try to get everything done before the end of January.
Best regards
Linus Björnstam
On Sun, 5 Jan 2020, at 12:30, Andy Wingo wrote:
> Hi :)
>
> Since this is a final SRFI I think there's no problem getting it in.
> Some formatting notes follow; since it's your first Guile patch I'm a
> bit verbose :) Probably this will miss 3.0.0 but make 3.0.1, FWIW.
>
> On Sun 22 Dec 2019 15:55, Linus Björnstam <linus.bjornstam@veryfast.biz> writes:
>
> > From 7e8d3b22ba5f814c40dbb5ab616a318c0cdc2f3e Mon Sep 17 00:00:00 2001
> > From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> > Date: Sun, 22 Dec 2019 15:38:34 +0100
> > Subject: [PATCH 1/2] Added srfi-171 to guile under the module name (srfi
> > srfi-171).
> >
> > For more info, read the SRFI document: https://srfi.schemers.org/srfi-171/srfi-171.html
>
> Needs a note per-file; see other commit log messages. Also please wrap
> to 72 characters.
>
> > --- /dev/null
> > +++ b/module/srfi/srfi-171.scm
> > @@ -0,0 +1,498 @@
> > +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> > +;; Copyright 2019 Linus Bj.rnstam
> > +;;
>
> I think you've assigned copyright so this can have the standard Guile
> copyright block, right?
>
> > +;; This module name is guile-specific. The correct module name is of course
> > +;; (srfi 171)
>
> I don't think it's right to say there is a "correct" name. R6RS, R7RS,
> and Guile have different naming conventions for SRFI modules and that's
> OK.
>
> The style in Guile is generally that block comments like this should be
> complete sentences, starting with capital letters and including
> terminating punctuation. Generally we do two spaces after periods,
> also.
>
> > +(define-module (srfi srfi-171)
> > + #:declarative? #t
> > + #: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
>
> Better to put rcons on its own line so that other exports are also
> aligned with the open paren.
>
> > +;; A special value to be used as a placeholder where no value has been set and #f
> > +;; doesn't cut it. Not exported.
> > +
> > +(define-record-type <nothing>
> > + (make-nothing)
> > + nothing?)
> > +(define nothing (make-nothing))
>
> Note that this can be somewhat cheaper as:
>
> (define nothing (list 'nothing))
> (define (nothing? x) (eq? x nothing))
>
> > +;; helper function which ensures x is reduced.
>
> Capitalize. FWIW, better done as a docstring:
>
> (define (ensure-reduced x)
> "Ensure that @var{x} is reduced."
> ...)
>
> > +;; 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.
>
> Capitalize and limit to 80 characters wide.
>
> > +(define (preserving-reduced f)
> > + (lambda (a b)
> > + (let ((return (f a b)))
> > + (if (reduced? return)
> > + (reduced return)
> > + return))))
> > +
> > +
> > +
> > +
>
> Generally, put one blank line between functions. Two lines can be
> between sections. Four is too much :)
>
> > +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> > +;; Reducing functions meant to be used at the end at the transducing
> > +;; process. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> This is a fairly non-standard comment style, FWIW; consider just
> prefixing with ";;;".
>
> > +;; a transducer-friendly cons with the empty list as identity
> > +(define rcons
> > + (case-lambda
>
> Similar comment regarding docstrings
>
> > +;; Use this as the f in transduce to count the amount of elements passed through.
> > +;; (transduce (tfilter odd?) tcount (list 1 2 3)) => 2
>
> 80 characters, and the example can go in an @example if you like:
>
> (define rcount
> (case-lambda
> "A transducer that counts the number of elements passing through. \
> @example
> (transduce (tfilter odd?) tcount (list 1 2 3)) @result{} 2
> @end example"
> ...))
>
> > +(define (make-replacer map)
> > + (cond
> > + ((list? map)
> > + (lambda (x)
> > + (let ((replacer? (assoc x map)))
> > + (if replacer?
> > + (cdr replacer?)
> > + x))))
>
> I generally find this sort of thing better with (ice-9 match):
>
> (match (assoc x map)
> ((x . replacer) replacer)
> (#f x))
>
> > +;; Flattens everything and passes each value through the reducer
> > +;; (list-transduce tflatten conj (list 1 2 (list 3 4 '(5 6) 7 8))) => (1 2 3 4 5 6 7 8)
>
> 80 chars
>
> > +;; I am not sure about the correctness of this. It seems to work.
> > +;; we could maybe make it faster?
> > +(define (tpartition f)
>
> How could you know about the correctness? Probably a good idea to do
> what it takes to be sure and then remove the comment. Regarding speed,
> I would remove the comment, if it's slow then people can work on it.
>
> Note that in general comments shouldn't be from a first-person
> perspective, because the code will be maintained as part of Guile, not
> necessarily by the author.
>
> > diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm
> > new file mode 100644
> > index 000000000..9aa8ab28e
> > --- /dev/null
> > +++ b/module/srfi/srfi-171/gnu.scm
> > @@ -0,0 +1,49 @@
> > +(define-module (srfi srfi-171 gnu)
>
> Needs a copyright header
>
> > diff --git a/module/srfi/srfi-171/meta.scm b/module/srfi/srfi-171/meta.scm
> > new file mode 100644
> > index 000000000..dd1fd06c4
> > --- /dev/null
> > +++ b/module/srfi/srfi-171/meta.scm
> > @@ -0,0 +1,115 @@
> > +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> > +;; Copyright 2019 Linus Bj.rnstam
>
> Probably should be a Guile copyright header
> > diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
> > new file mode 100644
> > index 000000000..c6d574af2
> > --- /dev/null
> > +++ b/test-suite/tests/srfi-171.test
> > @@ -0,0 +1,195 @@
> > +;; TODO: test all transducers that take an equality predicate
> > +;; TODO: test treplace with all kinds of hash tables
> > +
> > +(define-module (test-srfi-171)
>
> Needs a copyright header
>
> > From 39be4808f5921a716916de6f4db03990412f2518 Mon Sep 17 00:00:00 2001
> > From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> > Date: Sun, 22 Dec 2019 15:39:35 +0100
> > Subject: [PATCH 2/2] Added documentation and tests for srfi-171.
> >
> > * doc/ref/srfi-modules.texi - Adapted and added the srfi document to the
> > guile srfi documentation
> > * module/Makefile.am - Added the srfi files for compilation
> > * test-suite/Makefile.am - Added the srfi-171.test to the test suite.
>
> Thanks for the per-file notes :)
>
> FWIW the general format would be like:
>
> * doc/ref/srfi-modules.texi:
> * module/Makefile.am (SOURCES):
> * test-suite/Makefile.am (SCM_TESTS): Add srfi-171.
>
> I.e. colons after the file, and the changed function or variable in
> parens, and then the tense is present: it describes the change. See
> https://www.gnu.org/prep/standards/html_node/Change-Logs.html (though we
> adapt it for Git).
>
> > +@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.
>
> Limit to 80 chars please. In Emacs you'd do M-q to do this.
>
> > +@itemize @bullet
>
> Probably you can leave off @bullet.
>
> > +@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
>
> Probably better style to have just one empty line. I would also break
> the last line.
>
> Cheers,
>
> Andy
>
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2020-01-05 11:30 ` Andy Wingo
2020-01-05 13:34 ` Linus Björnstam
@ 2020-01-16 19:52 ` Linus Björnstam
2020-03-08 14:40 ` Ludovic Courtès
1 sibling, 1 reply; 9+ messages in thread
From: Linus Björnstam @ 2020-01-16 19:52 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 8979 bytes --]
I have addressed all your feedback and present to you the revised patch.
Some small code changes compared to the other patch. Most significantly,
tsegment and tpartition have gotten paranoid about the downstream
reducer managing to sneak a reduced value through (with no performance
impact, mind you). Apart from that, some docstrings were added where it
seemed sane, some accidental code duplication between (srfi srfi-171)
and (srfi srfi-171 meta) was fixed.
The only thing I am scared of is thunderbird accidentally sending this
mail as HTML and maybe getting the commit message formatting wrong.
Best regards
Linus Björnstam
On 2020-01-05 12:30, Andy Wingo wrote:
> Hi :)
>
> Since this is a final SRFI I think there's no problem getting it in.
> Some formatting notes follow; since it's your first Guile patch I'm a
> bit verbose :) Probably this will miss 3.0.0 but make 3.0.1, FWIW.
>
> On Sun 22 Dec 2019 15:55, Linus Björnstam <linus.bjornstam@veryfast.biz> writes:
>
>> From 7e8d3b22ba5f814c40dbb5ab616a318c0cdc2f3e Mon Sep 17 00:00:00 2001
>> From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
>> Date: Sun, 22 Dec 2019 15:38:34 +0100
>> Subject: [PATCH 1/2] Added srfi-171 to guile under the module name (srfi
>> srfi-171).
>>
>> For more info, read the SRFI document: https://srfi.schemers.org/srfi-171/srfi-171.html
> Needs a note per-file; see other commit log messages. Also please wrap
> to 72 characters.
>
>> --- /dev/null
>> +++ b/module/srfi/srfi-171.scm
>> @@ -0,0 +1,498 @@
>> +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>> +;; Copyright 2019 Linus Bj.rnstam
>> +;;
> I think you've assigned copyright so this can have the standard Guile
> copyright block, right?
>
>> +;; This module name is guile-specific. The correct module name is of course
>> +;; (srfi 171)
> I don't think it's right to say there is a "correct" name. R6RS, R7RS,
> and Guile have different naming conventions for SRFI modules and that's
> OK.
>
> The style in Guile is generally that block comments like this should be
> complete sentences, starting with capital letters and including
> terminating punctuation. Generally we do two spaces after periods,
> also.
>
>> +(define-module (srfi srfi-171)
>> + #:declarative? #t
>> + #: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
> Better to put rcons on its own line so that other exports are also
> aligned with the open paren.
>
>> +;; A special value to be used as a placeholder where no value has been set and #f
>> +;; doesn't cut it. Not exported.
>> +
>> +(define-record-type <nothing>
>> + (make-nothing)
>> + nothing?)
>> +(define nothing (make-nothing))
> Note that this can be somewhat cheaper as:
>
> (define nothing (list 'nothing))
> (define (nothing? x) (eq? x nothing))
>
>> +;; helper function which ensures x is reduced.
> Capitalize. FWIW, better done as a docstring:
>
> (define (ensure-reduced x)
> "Ensure that @var{x} is reduced."
> ...)
>
>> +;; 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.
> Capitalize and limit to 80 characters wide.
>
>> +(define (preserving-reduced f)
>> + (lambda (a b)
>> + (let ((return (f a b)))
>> + (if (reduced? return)
>> + (reduced return)
>> + return))))
>> +
>> +
>> +
>> +
> Generally, put one blank line between functions. Two lines can be
> between sections. Four is too much :)
>
>> +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>> +;; Reducing functions meant to be used at the end at the transducing
>> +;; process. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> This is a fairly non-standard comment style, FWIW; consider just
> prefixing with ";;;".
>
>> +;; a transducer-friendly cons with the empty list as identity
>> +(define rcons
>> + (case-lambda
> Similar comment regarding docstrings
>
>> +;; Use this as the f in transduce to count the amount of elements passed through.
>> +;; (transduce (tfilter odd?) tcount (list 1 2 3)) => 2
> 80 characters, and the example can go in an @example if you like:
>
> (define rcount
> (case-lambda
> "A transducer that counts the number of elements passing through. \
> @example
> (transduce (tfilter odd?) tcount (list 1 2 3)) @result{} 2
> @end example"
> ...))
>
>> +(define (make-replacer map)
>> + (cond
>> + ((list? map)
>> + (lambda (x)
>> + (let ((replacer? (assoc x map)))
>> + (if replacer?
>> + (cdr replacer?)
>> + x))))
> I generally find this sort of thing better with (ice-9 match):
>
> (match (assoc x map)
> ((x . replacer) replacer)
> (#f x))
>
>> +;; Flattens everything and passes each value through the reducer
>> +;; (list-transduce tflatten conj (list 1 2 (list 3 4 '(5 6) 7 8))) => (1 2 3 4 5 6 7 8)
> 80 chars
>
>> +;; I am not sure about the correctness of this. It seems to work.
>> +;; we could maybe make it faster?
>> +(define (tpartition f)
> How could you know about the correctness? Probably a good idea to do
> what it takes to be sure and then remove the comment. Regarding speed,
> I would remove the comment, if it's slow then people can work on it.
>
> Note that in general comments shouldn't be from a first-person
> perspective, because the code will be maintained as part of Guile, not
> necessarily by the author.
>
>> diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm
>> new file mode 100644
>> index 000000000..9aa8ab28e
>> --- /dev/null
>> +++ b/module/srfi/srfi-171/gnu.scm
>> @@ -0,0 +1,49 @@
>> +(define-module (srfi srfi-171 gnu)
> Needs a copyright header
>
>> diff --git a/module/srfi/srfi-171/meta.scm b/module/srfi/srfi-171/meta.scm
>> new file mode 100644
>> index 000000000..dd1fd06c4
>> --- /dev/null
>> +++ b/module/srfi/srfi-171/meta.scm
>> @@ -0,0 +1,115 @@
>> +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>> +;; Copyright 2019 Linus Bj.rnstam
> Probably should be a Guile copyright header
>> diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
>> new file mode 100644
>> index 000000000..c6d574af2
>> --- /dev/null
>> +++ b/test-suite/tests/srfi-171.test
>> @@ -0,0 +1,195 @@
>> +;; TODO: test all transducers that take an equality predicate
>> +;; TODO: test treplace with all kinds of hash tables
>> +
>> +(define-module (test-srfi-171)
> Needs a copyright header
>
>> From 39be4808f5921a716916de6f4db03990412f2518 Mon Sep 17 00:00:00 2001
>> From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
>> Date: Sun, 22 Dec 2019 15:39:35 +0100
>> Subject: [PATCH 2/2] Added documentation and tests for srfi-171.
>>
>> * doc/ref/srfi-modules.texi - Adapted and added the srfi document to the
>> guile srfi documentation
>> * module/Makefile.am - Added the srfi files for compilation
>> * test-suite/Makefile.am - Added the srfi-171.test to the test suite.
> Thanks for the per-file notes :)
>
> FWIW the general format would be like:
>
> * doc/ref/srfi-modules.texi:
> * module/Makefile.am (SOURCES):
> * test-suite/Makefile.am (SCM_TESTS): Add srfi-171.
>
> I.e. colons after the file, and the changed function or variable in
> parens, and then the tense is present: it describes the change. See
> https://www.gnu.org/prep/standards/html_node/Change-Logs.html (though we
> adapt it for Git).
>
>> +@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.
> Limit to 80 chars please. In Emacs you'd do M-q to do this.
>
>> +@itemize @bullet
> Probably you can leave off @bullet.
>
>> +@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
> Probably better style to have just one empty line. I would also break
> the last line.
>
> Cheers,
>
> Andy
--
- Linus Björnstam
[-- Attachment #2: 0001-Add-SRFI-171-transducers-to-guile.patch --]
[-- Type: text/plain, Size: 48793 bytes --]
From c382d7808a8d41cd4e9ef8a17b7ba9553835499b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
Date: Thu, 16 Jan 2020 20:31:45 +0100
Subject: [PATCH] Add 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.
---
doc/ref/srfi-modules.texi | 518 +++++++++++++++++++++++++++++++++
module/Makefile.am | 3 +
module/srfi/srfi-171.scm | 458 +++++++++++++++++++++++++++++
module/srfi/srfi-171/gnu.scm | 65 +++++
module/srfi/srfi-171/meta.scm | 113 +++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-171.test | 195 +++++++++++++
7 files changed, 1353 insertions(+)
create mode 100644 module/srfi/srfi-171.scm
create mode 100644 module/srfi/srfi-171/gnu.scm
create mode 100644 module/srfi/srfi-171/meta.scm
create mode 100644 test-suite/tests/srfi-171.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8f5b643c6..fcc4231a7 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -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,523 @@ 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: @code{(compose
+(tfilter odd?) (tmap (lambda (x) (* x x))))} 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 functions.
+
+@itemize
+@item
+(): Produce an identity
+
+@item
+(result-so-far): completion. If you have nothing to do, then just return
+the result so far
+
+@item
+(result-so-far input) do whatever you like to the input and produce a
+new 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 function that takes a reducer and produces a
+reducing function that behaves as follows:
+
+@itemize
+@item
+(): 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: @code{ (list-transduce (tfilter odd?)
++ '(1 2 3 4 5))}. 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
+ 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
+ Initializes the transducer @code{xform} by passing the reducer @code{f}
+ to it. If no identity is provided, @code{f} is run without arguments to
+ return the reducer identity. It then reduces over @code{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 sample 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 @code{(reader)} until the
+EOF-object is returned, presumably to read from
+@code{current-input-port}. With a port @code{reader} is applied to
+@code{port} instead of without any arguments. If an @code{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 @code{proc} to all values. Stateless.
+@end deffn
+
+
+@deffn tfilter pred?
+Returns a transducer that removes values for which @code{pred?} returns #f.
+
+Stateless.
+@end deffn
+
+
+@deffn {Scheme Procedure} tremove pred?
+Returns a transducer that removes values for which @code{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 @code{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 n values.
+
+Stateful.
+@end deffn
+
+
+@deffn {Scheme Procedure} ttake n
+Returns a transducer that discards all values and stops the transduction
+after the first 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
+@code{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 @code{pred?} has
+returned #f. Any subsequent values are ignored and the last successful
+value is returned. @code{retf} is a function that gets called whenever
+@code{pred?} returns false. The arguments passed are the result so far
+and the input for which pred? returns #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 @code{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 @code{equality-predicate}. The default
+@code{equality-predicate} is @code{equal?}.
+
+Stateful.
+@end deffn
+
+
+@deffn {Scheme Procedure} tsegment n
+
+Returns a transducer that groups @code{n} inputs in lists of @code{n}
+elements. When the transduction stops, it flushes any remaining
+collection, even if it contains fewer than @code{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 @code{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
+@code{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 @code{logger} procedure is discarded. The
+default @code{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 @code{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 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}. @code{f}
+is a reducer as returned by a transducer. @code{identity} is the
+identity (sometimes called "seed") of the reduction. @code{lst} is a
+list. If @code{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:
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..545581af5
--- /dev/null
+++ b/module/srfi/srfi-171.scm
@@ -0,0 +1,458 @@
+;; 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)
+ #:declarative? #t
+ #: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
+ "A reducer that tests input using @var{pred}. If any input satisfies
+@var{pred}, it returns @code{(reduced value)}."
+ (() #f)
+ ((result) result)
+ ((result input)
+ (let ((test (pred input)))
+ (if test
+ (reduced test)
+ #f)))))
+
+(define (revery pred)
+ (case-lambda
+ "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)
+ "Returns 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)
+ "tsegment returns 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)
+ "tpartition returns 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)
+ "Returns 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))
+ "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))))))
+
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3810197e2..cafa5c92b 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -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 \
diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
new file mode 100644
index 000000000..c6d574af2
--- /dev/null
+++ b/test-suite/tests/srfi-171.test
@@ -0,0 +1,195 @@
+;; TODO: test all transducers that take an equality predicate
+;; TODO: test treplace with all kinds of hash tables
+
+(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))))
--
2.24.1
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2020-01-16 19:52 ` Linus Björnstam
@ 2020-03-08 14:40 ` Ludovic Courtès
2020-03-08 17:11 ` Linus Björnstam
2020-03-23 17:17 ` Linus Björnstam
0 siblings, 2 replies; 9+ messages in thread
From: Ludovic Courtès @ 2020-03-08 14:40 UTC (permalink / raw)
To: Linus Björnstam; +Cc: Guile Devel
Hi Linus,
Linus Björnstam <linus.bjornstam@veryfast.biz> skribis:
> From c382d7808a8d41cd4e9ef8a17b7ba9553835499b Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> Date: Thu, 16 Jan 2020 20:31:45 +0100
> Subject: [PATCH] Add 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.
I think the patch is almost ready for inclusion, thanks for taking the
time to address Andy’s comments!
I have additional stylistic comments, and then I think we’re ready to go:
> +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: @code{(compose
> +(tfilter odd?) (tmap (lambda (x) (* x x))))} and reuse it with lists,
For readability, it’s probably best to use @example rather than @code
for the example above (for an example larger than a couple of words in
general.)
> +The central part of transducers are 3-arity reducing functions.
In general, RnRS and Guile use the term “procedure” rather than
“functions”. Not a big deal, but bonus points if you can adjust the
documentation accordingly. :-)
> +@itemize
> +@item
> +(): Produce an identity
s/an/the/ ?
> +@subheading The concept of transducers
> +
> +A transducer is a one-arity function that takes a reducer and produces a
> +reducing function that behaves as follows:
> +
> +@itemize
> +@item
> +(): calls reducer with no arguments (producing its identity)
It’s not clear from this where you’d write () (there’s a missing @code
here, right?), which is not a valid Scheme expression in itself.
Perhaps an extra bit of introduction is needed above for clarity?
Also, this is under the “Concept” heading, but it looks more like the
API, no?
> +@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.
Missing @code ornaments here.
> +a simple example is as following: @code{ (list-transduce (tfilter odd?)
^
Capital.
@example for the example.
> ++ '(1 2 3 4 5))}. 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
Please make sure to add two spaces after end-of-sentence periods
throughout the document.
> + Even though transducers appear to be somewhat of a generalisation of
> + map and friends, this is not really true. Since transducers don't know
s/map/@code{map}/
> +@deffn {Scheme Procedure} list-transduce xform f lst
> +@deffnx {Scheme Procedure} list-transduce xform f identity lst
> + Initializes the transducer @code{xform} by passing the reducer @code{f}
> + to it. If no identity is provided, @code{f} is run without arguments to
> + return the reducer identity. It then reduces over @code{lst} using the
> + identity as the seed.
Please remove the extra leading space. Also, use @var, and use
imperative tense, like so:
@deffn {Scheme Procedure} list-transduce @var{xform} @var{f} @var{lst}
Initialize the transducer @var{xform} by passing the reduce @var{f} to
it. …
@end deffn
> +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 sample implementation is just a value wrapped in a SRFI 9 record
> +type named "reduced". If such a value is returned by the transducer,
For proper typesetting, write ``reduced'' instead of "reduced".
s/SRFI /SRFI-/
> +Same as @code{list-transduce}, but for vectors, strings, u8-bytevectors
> +and srfi-158-styled generators respectively.
> +
> +@end deffn
Please remove the newline before @end deffn.
> +@node SRFI-171 Helpers
> +@subsubsection Helper functions for writing transducers
> +@cindex transducers helpers
> +
> +These functions are in the @code{(srfi 171 meta)} module and are only
^
(srfi srfi-171 meta)
> +@deffn {Scheme Procedure} reduced value
> +
> +Wraps a value in a @code{<reduced>} container, signalling that the
> +reduction should stop.
> +@end deffn
Please remove extra line before @deffn (throughout the document).
> +(define-module (srfi srfi-171)
> + #:declarative? #t
Is it necessary? If so, could you add a comment so our future selves
know whether this is still necessary? :-)
> +(define reverse-rcons
> + (case-lambda
> + "A transducer-friendly consing reducer with '() as identity.
> +The resulting list is in reverse order."
In general, the style for docstrings is to use imperative tense, like:
Return a consing reducer with the empty list as its identity.
(Throughout the file.)
Could you also add docstrings to the exported procedures that lack one?
(Docstrings can be short of course, no need to be as precise as in the
manual.)
> +++ b/test-suite/tests/srfi-171.test
> @@ -0,0 +1,195 @@
> +;; TODO: test all transducers that take an equality predicate
> +;; TODO: test treplace with all kinds of hash tables
Should we wait for these tests before merging? Tested code is always
better than untested code. :-)
Also, please add a Guile copyright header.
> + (pass-if "tfilter+tmap" (equal?
> + '(1 3 5)
> + (list-transduce (compose (tfilter even?) (tmap add1)) rcons numeric-list)))
Please wrap lines to 80 chars.
Could you send an updated patch?
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2020-03-08 14:40 ` Ludovic Courtès
@ 2020-03-08 17:11 ` Linus Björnstam
2020-03-23 17:17 ` Linus Björnstam
1 sibling, 0 replies; 9+ messages in thread
From: Linus Björnstam @ 2020-03-08 17:11 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guile Devel
Thanks! I will address all those.
The tests are written and passing, so I will remove the redundant TODOs.
--
Linus Björnstam
On Sun, 8 Mar 2020, at 15:40, Ludovic Courtès wrote:
> Hi Linus,
>
> Linus Björnstam <linus.bjornstam@veryfast.biz> skribis:
>
> > From c382d7808a8d41cd4e9ef8a17b7ba9553835499b Mon Sep 17 00:00:00 2001
> > From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> > Date: Thu, 16 Jan 2020 20:31:45 +0100
> > Subject: [PATCH] Add 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.
>
> I think the patch is almost ready for inclusion, thanks for taking the
> time to address Andy’s comments!
>
> I have additional stylistic comments, and then I think we’re ready to go:
>
> > +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: @code{(compose
> > +(tfilter odd?) (tmap (lambda (x) (* x x))))} and reuse it with lists,
>
> For readability, it’s probably best to use @example rather than @code
> for the example above (for an example larger than a couple of words in
> general.)
>
> > +The central part of transducers are 3-arity reducing functions.
>
> In general, RnRS and Guile use the term “procedure” rather than
> “functions”. Not a big deal, but bonus points if you can adjust the
> documentation accordingly. :-)
>
> > +@itemize
> > +@item
> > +(): Produce an identity
>
> s/an/the/ ?
>
> > +@subheading The concept of transducers
> > +
> > +A transducer is a one-arity function that takes a reducer and produces a
> > +reducing function that behaves as follows:
> > +
> > +@itemize
> > +@item
> > +(): calls reducer with no arguments (producing its identity)
>
> It’s not clear from this where you’d write () (there’s a missing @code
> here, right?), which is not a valid Scheme expression in itself.
> Perhaps an extra bit of introduction is needed above for clarity?
>
> Also, this is under the “Concept” heading, but it looks more like the
> API, no?
>
> > +@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.
>
> Missing @code ornaments here.
>
> > +a simple example is as following: @code{ (list-transduce (tfilter odd?)
> ^
> Capital.
>
> @example for the example.
>
> > ++ '(1 2 3 4 5))}. 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
>
> Please make sure to add two spaces after end-of-sentence periods
> throughout the document.
>
> > + Even though transducers appear to be somewhat of a generalisation of
> > + map and friends, this is not really true. Since transducers don't know
>
> s/map/@code{map}/
>
> > +@deffn {Scheme Procedure} list-transduce xform f lst
> > +@deffnx {Scheme Procedure} list-transduce xform f identity lst
> > + Initializes the transducer @code{xform} by passing the reducer @code{f}
> > + to it. If no identity is provided, @code{f} is run without arguments to
> > + return the reducer identity. It then reduces over @code{lst} using the
> > + identity as the seed.
>
> Please remove the extra leading space. Also, use @var, and use
> imperative tense, like so:
>
> @deffn {Scheme Procedure} list-transduce @var{xform} @var{f} @var{lst}
> Initialize the transducer @var{xform} by passing the reduce @var{f} to
> it. …
> @end deffn
>
> > +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 sample implementation is just a value wrapped in a SRFI 9 record
> > +type named "reduced". If such a value is returned by the transducer,
>
> For proper typesetting, write ``reduced'' instead of "reduced".
>
> s/SRFI /SRFI-/
>
> > +Same as @code{list-transduce}, but for vectors, strings, u8-bytevectors
> > +and srfi-158-styled generators respectively.
> > +
> > +@end deffn
>
> Please remove the newline before @end deffn.
>
> > +@node SRFI-171 Helpers
> > +@subsubsection Helper functions for writing transducers
> > +@cindex transducers helpers
> > +
> > +These functions are in the @code{(srfi 171 meta)} module and are only
> ^
> (srfi srfi-171 meta)
>
> > +@deffn {Scheme Procedure} reduced value
> > +
> > +Wraps a value in a @code{<reduced>} container, signalling that the
> > +reduction should stop.
> > +@end deffn
>
> Please remove extra line before @deffn (throughout the document).
>
> > +(define-module (srfi srfi-171)
> > + #:declarative? #t
>
> Is it necessary? If so, could you add a comment so our future selves
> know whether this is still necessary? :-)
>
> > +(define reverse-rcons
> > + (case-lambda
> > + "A transducer-friendly consing reducer with '() as identity.
> > +The resulting list is in reverse order."
>
> In general, the style for docstrings is to use imperative tense, like:
>
> Return a consing reducer with the empty list as its identity.
>
> (Throughout the file.)
>
> Could you also add docstrings to the exported procedures that lack one?
> (Docstrings can be short of course, no need to be as precise as in the
> manual.)
>
> > +++ b/test-suite/tests/srfi-171.test
> > @@ -0,0 +1,195 @@
> > +;; TODO: test all transducers that take an equality predicate
> > +;; TODO: test treplace with all kinds of hash tables
>
> Should we wait for these tests before merging? Tested code is always
> better than untested code. :-)
>
> Also, please add a Guile copyright header.
>
> > + (pass-if "tfilter+tmap" (equal?
> > + '(1 3 5)
> > + (list-transduce (compose (tfilter even?) (tmap add1)) rcons numeric-list)))
>
> Please wrap lines to 80 chars.
>
> Could you send an updated patch?
>
> Thank you!
>
> Ludo’.
>
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2020-03-08 14:40 ` Ludovic Courtès
2020-03-08 17:11 ` Linus Björnstam
@ 2020-03-23 17:17 ` Linus Björnstam
2020-03-25 21:48 ` Ludovic Courtès
1 sibling, 1 reply; 9+ messages in thread
From: Linus Björnstam @ 2020-03-23 17:17 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Guile Devel
[-- Attachment #1: Type: text/plain, Size: 7361 bytes --]
Hi Ludo!
All things except some of the docstrings are fixed. The reason not all of the docstrings are fixed according to the suggestion is that the reducers you specifically used as examples do not return reducers, but ARE reducers, and specifically they are srfi-171-styled reducers. i.e: they do not return anything, but are meant to be used without calling them: (list-transduce (tmap 1+) rcons '(1 2 3)), in contrast to (list-transduce (tmap 1+) (revery odd?) '(1 3 5 6)). All other docstrings and all other suggestions are addressed.
It compiles fine against the latest master on my ARM64 linux computer.
Best regards
Linus Björnstam
On Sun, 8 Mar 2020, at 15:40, Ludovic Courtès wrote:
> Hi Linus,
>
> Linus Björnstam <linus.bjornstam@veryfast.biz> skribis:
>
> > From c382d7808a8d41cd4e9ef8a17b7ba9553835499b Mon Sep 17 00:00:00 2001
> > From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> > Date: Thu, 16 Jan 2020 20:31:45 +0100
> > Subject: [PATCH] Add 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.
>
> I think the patch is almost ready for inclusion, thanks for taking the
> time to address Andy’s comments!
>
> I have additional stylistic comments, and then I think we’re ready to go:
>
> > +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: @code{(compose
> > +(tfilter odd?) (tmap (lambda (x) (* x x))))} and reuse it with lists,
>
> For readability, it’s probably best to use @example rather than @code
> for the example above (for an example larger than a couple of words in
> general.)
>
> > +The central part of transducers are 3-arity reducing functions.
>
> In general, RnRS and Guile use the term “procedure” rather than
> “functions”. Not a big deal, but bonus points if you can adjust the
> documentation accordingly. :-)
>
> > +@itemize
> > +@item
> > +(): Produce an identity
>
> s/an/the/ ?
>
> > +@subheading The concept of transducers
> > +
> > +A transducer is a one-arity function that takes a reducer and produces a
> > +reducing function that behaves as follows:
> > +
> > +@itemize
> > +@item
> > +(): calls reducer with no arguments (producing its identity)
>
> It’s not clear from this where you’d write () (there’s a missing @code
> here, right?), which is not a valid Scheme expression in itself.
> Perhaps an extra bit of introduction is needed above for clarity?
>
> Also, this is under the “Concept” heading, but it looks more like the
> API, no?
>
> > +@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.
>
> Missing @code ornaments here.
>
> > +a simple example is as following: @code{ (list-transduce (tfilter odd?)
> ^
> Capital.
>
> @example for the example.
>
> > ++ '(1 2 3 4 5))}. 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
>
> Please make sure to add two spaces after end-of-sentence periods
> throughout the document.
>
> > + Even though transducers appear to be somewhat of a generalisation of
> > + map and friends, this is not really true. Since transducers don't know
>
> s/map/@code{map}/
>
> > +@deffn {Scheme Procedure} list-transduce xform f lst
> > +@deffnx {Scheme Procedure} list-transduce xform f identity lst
> > + Initializes the transducer @code{xform} by passing the reducer @code{f}
> > + to it. If no identity is provided, @code{f} is run without arguments to
> > + return the reducer identity. It then reduces over @code{lst} using the
> > + identity as the seed.
>
> Please remove the extra leading space. Also, use @var, and use
> imperative tense, like so:
>
> @deffn {Scheme Procedure} list-transduce @var{xform} @var{f} @var{lst}
> Initialize the transducer @var{xform} by passing the reduce @var{f} to
> it. …
> @end deffn
>
> > +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 sample implementation is just a value wrapped in a SRFI 9 record
> > +type named "reduced". If such a value is returned by the transducer,
>
> For proper typesetting, write ``reduced'' instead of "reduced".
>
> s/SRFI /SRFI-/
>
> > +Same as @code{list-transduce}, but for vectors, strings, u8-bytevectors
> > +and srfi-158-styled generators respectively.
> > +
> > +@end deffn
>
> Please remove the newline before @end deffn.
>
> > +@node SRFI-171 Helpers
> > +@subsubsection Helper functions for writing transducers
> > +@cindex transducers helpers
> > +
> > +These functions are in the @code{(srfi 171 meta)} module and are only
> ^
> (srfi srfi-171 meta)
>
> > +@deffn {Scheme Procedure} reduced value
> > +
> > +Wraps a value in a @code{<reduced>} container, signalling that the
> > +reduction should stop.
> > +@end deffn
>
> Please remove extra line before @deffn (throughout the document).
>
> > +(define-module (srfi srfi-171)
> > + #:declarative? #t
>
> Is it necessary? If so, could you add a comment so our future selves
> know whether this is still necessary? :-)
>
> > +(define reverse-rcons
> > + (case-lambda
> > + "A transducer-friendly consing reducer with '() as identity.
> > +The resulting list is in reverse order."
>
> In general, the style for docstrings is to use imperative tense, like:
>
> Return a consing reducer with the empty list as its identity.
>
> (Throughout the file.)
>
> Could you also add docstrings to the exported procedures that lack one?
> (Docstrings can be short of course, no need to be as precise as in the
> manual.)
>
> > +++ b/test-suite/tests/srfi-171.test
> > @@ -0,0 +1,195 @@
> > +;; TODO: test all transducers that take an equality predicate
> > +;; TODO: test treplace with all kinds of hash tables
>
> Should we wait for these tests before merging? Tested code is always
> better than untested code. :-)
>
> Also, please add a Guile copyright header.
>
> > + (pass-if "tfilter+tmap" (equal?
> > + '(1 3 5)
> > + (list-transduce (compose (tfilter even?) (tmap add1)) rcons numeric-list)))
>
> Please wrap lines to 80 chars.
>
> Could you send an updated patch?
>
> Thank you!
>
> Ludo’.
>
[-- Attachment #2: 0001-Add-SRFI-171-to-guile.patch --]
[-- Type: application/octet-stream, Size: 51180 bytes --]
From 1450661c2432522ee41b43dffd05e46384a3ff1b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
Date: Mon, 23 Mar 2020 14:59:39 +0100
Subject: [PATCH] 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.
---
doc/ref/srfi-modules.texi | 487 +++++++++++++++++++++++++++++++++
module/Makefile.am | 3 +
module/srfi/srfi-171.scm | 457 +++++++++++++++++++++++++++++++
module/srfi/srfi-171/gnu.scm | 65 +++++
module/srfi/srfi-171/meta.scm | 113 ++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-171.test | 267 ++++++++++++++++++
7 files changed, 1393 insertions(+)
create mode 100644 module/srfi/srfi-171.scm
create mode 100644 module/srfi/srfi-171/gnu.scm
create mode 100644 module/srfi/srfi-171/meta.scm
create mode 100644 test-suite/tests/srfi-171.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8f5b643c6..fd190799c 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -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:
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))))))
+
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0dc86b020..8158aaf44 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -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 \
diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test
new file mode 100644
index 000000000..1ef7bc5f2
--- /dev/null
+++ b/test-suite/tests/srfi-171.test
@@ -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))))
--
2.25.0
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: [PATCH] Add srfi-171 to guile
2020-03-23 17:17 ` Linus Björnstam
@ 2020-03-25 21:48 ` Ludovic Courtès
0 siblings, 0 replies; 9+ messages in thread
From: Ludovic Courtès @ 2020-03-25 21:48 UTC (permalink / raw)
To: Linus Björnstam; +Cc: Guile Devel
Hi Linus,
Linus Björnstam <linus.bjornstam@veryfast.biz> skribis:
> From 1450661c2432522ee41b43dffd05e46384a3ff1b Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= <linus.bjornstam@fastmail.se>
> Date: Mon, 23 Mar 2020 14:59:39 +0100
> Subject: [PATCH] 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.
Perfect, applied! It’s great to have this part of Guile proper.
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2020-03-25 21:48 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-12-22 14:55 [PATCH] Add srfi-171 to guile Linus Björnstam
2019-12-22 20:45 ` Linus Björnstam
2020-01-05 11:30 ` Andy Wingo
2020-01-05 13:34 ` Linus Björnstam
2020-01-16 19:52 ` Linus Björnstam
2020-03-08 14:40 ` Ludovic Courtès
2020-03-08 17:11 ` Linus Björnstam
2020-03-23 17:17 ` Linus Björnstam
2020-03-25 21:48 ` Ludovic Courtès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).