meta.scm 3.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114
  1. ;; Copyright (C) 2020 Free Software Foundation, Inc.
  2. ;;
  3. ;; This library is free software; you can redistribute it and/or
  4. ;; modify it under the terms of the GNU Lesser General Public
  5. ;; License as published by the Free Software Foundation; either
  6. ;; version 3 of the License, or (at your option) any later version.
  7. ;;
  8. ;; This library is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this library; if not, write to the Free Software
  15. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. (define-module (srfi srfi-171 meta)
  17. #:use-module (srfi srfi-9)
  18. #:use-module ((rnrs bytevectors) #:select (bytevector-length bytevector-u8-ref))
  19. #:export (reduced reduced?
  20. unreduce
  21. ensure-reduced
  22. preserving-reduced
  23. list-reduce
  24. vector-reduce
  25. string-reduce
  26. bytevector-u8-reduce
  27. port-reduce
  28. generator-reduce))
  29. ;; A reduced value is stops the transduction.
  30. (define-record-type <reduced>
  31. (reduced val)
  32. reduced?
  33. (val unreduce))
  34. (define (ensure-reduced x)
  35. "Ensure that @var{x} is reduced"
  36. (if (reduced? x)
  37. x
  38. (reduced x)))
  39. ;; helper function that wraps a reduced value twice since reducing functions (like list-reduce)
  40. ;; unwraps them. tconcatenate is a good example: it re-uses it's reducer on it's input using list-reduce.
  41. ;; If that reduction finishes early and returns a reduced value, list-reduce would "unreduce"
  42. ;; that value and try to continue the transducing process.
  43. (define (preserving-reduced reducer)
  44. (lambda (a b)
  45. (let ((return (reducer a b)))
  46. (if (reduced? return)
  47. (reduced return)
  48. return))))
  49. ;; This is where the magic tofu is cooked
  50. (define (list-reduce f identity lst)
  51. (if (null? lst)
  52. identity
  53. (let ((v (f identity (car lst))))
  54. (if (reduced? v)
  55. (unreduce v)
  56. (list-reduce f v (cdr lst))))))
  57. (define (vector-reduce f identity vec)
  58. (let ((len (vector-length vec)))
  59. (let loop ((i 0) (acc identity))
  60. (if (= i len)
  61. acc
  62. (let ((acc (f acc (vector-ref vec i))))
  63. (if (reduced? acc)
  64. (unreduce acc)
  65. (loop (+ i 1) acc)))))))
  66. (define (string-reduce f identity str)
  67. (let ((len (string-length str)))
  68. (let loop ((i 0) (acc identity))
  69. (if (= i len)
  70. acc
  71. (let ((acc (f acc (string-ref str i))))
  72. (if (reduced? acc)
  73. (unreduce acc)
  74. (loop (+ i 1) acc)))))))
  75. (define (bytevector-u8-reduce f identity vec)
  76. (let ((len (bytevector-length vec)))
  77. (let loop ((i 0) (acc identity))
  78. (if (= i len)
  79. acc
  80. (let ((acc (f acc (bytevector-u8-ref vec i))))
  81. (if (reduced? acc)
  82. (unreduce acc)
  83. (loop (+ i 1) acc)))))))
  84. (define (port-reduce f identity reader port)
  85. (let loop ((val (reader port)) (acc identity))
  86. (if (eof-object? val)
  87. acc
  88. (let ((acc (f acc val)))
  89. (if (reduced? acc)
  90. (unreduce acc)
  91. (loop (reader port) acc))))))
  92. (define (generator-reduce f identity gen)
  93. (let loop ((val (gen)) (acc identity))
  94. (if (eof-object? val)
  95. acc
  96. (let ((acc (f acc val)))
  97. (if (reduced? acc)
  98. (unreduce acc)
  99. (loop (gen) acc))))))