Add SRFIs 165 and 166 (monadic formatting)

Also patches 130 to support string-copy with optional arguments, as in
the spec.

The SRFI 166 test suite is included but it depends on Alex Shinn’s
`(chibi test)`. This is available for Chez here:
<https://codeberg.org/dpk/chibi-lib>
but as it’s not (yet) a SRFI of its own, I’ve excluded it from here
and left the tests in the SRFI directory rather than putting them in
tests/. For me on Chez 10.0.0, all of the tests pass except for two
spurious failures (the test expects lowercase hex digits where Chez
gives uppercase ones, but this is not actually specified by the SRFI
so either is okay).

%3a130/string-cursors.sls

@@ -24,8 +24,9 @@
     string-reverse string-concatenate string-concatenate-reverse string-fold
     string-fold-right string-for-each-cursor string-replicate string-count
     string-replace string-split string-filter string-remove)
-  (import (rnrs)
-          (rename (only (srfi :13) string-index string-index-right
+  (import (except (rnrs) string-copy)
+          (rename (only (srfi :13) string-copy
+                        string-index string-index-right
                         string-contains string-filter string-replace
                         string-count string-fold-right string-fold
                         string-concatenate-reverse string-concatenate

%3a165.sls

@@ -0,0 +1,46 @@
+;; Copyright (C) Marc Nieper-Wißkirchen (2019).  All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice (including
+;; the next paragraph) shall be included in all copies or substantial
+;; portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(library (srfi :165)
+  (export make-computation-environment-variable
+          make-computation-environment computation-environment-ref
+          computation-environment-update
+          computation-environment-update! computation-environment-copy
+          make-computation computation-each computation-each-in-list
+          computation-pure computation-bind computation-sequence
+          computation-run computation-ask computation-local
+          computation-fn computation-with computation-with!
+          computation-forked computation-bind/forked
+          default-computation
+          define-computation-type)
+  (import (except (rnrs)
+                  define-record-type)
+          (srfi :9)
+          (srfi :111)
+          (srfi :125)
+          (srfi :128)
+          (only (srfi :133 vectors) vector-copy)
+          (srfi :146)
+          (srfi :244)
+          (srfi private include))
+  (include/resolve ("srfi" "%3a165") "implementation.scm"))

%3a165/implementation.scm

@@ -0,0 +1,283 @@
+;; Copyright (C) Marc Nieper-Wißkirchen (2019).  All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice (including
+;; the next paragraph) shall be included in all copies or substantial
+;; portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-record-type Computation-Environment-Variable
+  (make-environment-variable name default immutable? id)
+  environment-variable?
+  (name environment-variable-name)
+  (default environment-variable-default)
+  (immutable? environment-variable-immutable?)
+  (id environment-variable-id))
+
+(define make-computation-environment-variable
+  (let ((count 0))
+    (lambda (name default immutable?)
+      (set! count (+ count 1))
+      (make-environment-variable name default immutable? (- count)))))
+
+(define (predefined? var)
+  (not (negative? (environment-variable-id var))))
+
+(define variable-comparator
+  (make-comparator environment-variable?
+                   eq?
+                   (lambda (x y)
+                     (< (environment-variable-id x)
+                        (environment-variable-id y)))
+                   (lambda (x . y)
+                     (environment-variable-id x))))
+
+(define default-computation
+  (make-computation-environment-variable 'default-computation #f #f))
+
+(define (environment-global env)
+  (vector-ref env 0))
+
+(define (environment-local env)
+  (vector-ref env 1))
+
+(define (environment-set-global! env global)
+  (vector-set! env 0 global))
+
+(define (environment-set-local! env local)
+  (vector-set! env 1 local))
+
+(define (environment-cell-set! env var box)
+  (vector-set! env (+ 2 (environment-variable-id var)) box))
+
+(define (environment-cell env var)
+  (vector-ref env (+ 2 (environment-variable-id var))))
+
+(define-syntax define-computation-type
+  (syntax-rules ()
+    ((define-computation-type make-environment run var ...)
+     (%define-computation-type make-environment run (var ...) 0 ()))))
+
+(define-syntax %define-computation-type
+  (syntax-rules ()
+    ((_ make-environment run () n ((var default e immutable i) ...))
+     (begin
+       (define-values (e ...) (values default ...))
+       (define var (make-environment-variable 'var e immutable i))
+       ...
+       (define (make-environment)
+         (let ((env (make-vector (+ n 2))))
+           (environment-set-global! env (hash-table variable-comparator))
+           (environment-set-local! env (mapping variable-comparator))
+           (vector-set! env (+ i 2) (box e))
+           ...
+           env))
+       (define (run computation)
+         (execute computation (make-environment)))))
+    ((_ make-environment run ((v d) . v*) n (p ...))
+     (%define-computation-type make-environment run v* (+ n 1) (p ... (v d e #f n))))
+    ((_ make-environment run ((v d "immutable") . v*) n (p ...))
+     (%define-computation-type make-environment run v* (+ n 1) (p ... (v d e #t n))))
+    ((_ make-environment run (v . v*) n (p ...))
+     (%define-computation-type make-environment run v* (+ n 1) (p ... (v #f e #f n))))))
+
+(define-computation-type make-computation-environment computation-run)
+
+(define (computation-environment-ref env var)
+  (if (predefined? var)
+      (unbox (environment-cell env var))
+      (mapping-ref
+       (environment-local env)
+       var
+       (lambda ()
+         (hash-table-ref/default (environment-global env)
+                                 var
+                                 (environment-variable-default var)))
+       unbox)))
+
+(define (computation-environment-update env . arg*)
+  (let ((new-env (vector-copy env)))
+    (let loop ((arg* arg*)
+               (local (environment-local env)))
+      (if (null? arg*)
+          (begin
+            (environment-set-local! new-env local)
+            new-env)
+          (let ((var (car arg*))
+                (val (cadr arg*)))
+            (if (predefined? var)
+                (begin
+                  (environment-cell-set! new-env var (box val))
+                  (loop (cddr arg*) local))
+                (loop (cddr arg*) (mapping-set local var (box val)))))))))
+
+(define (computation-environment-update! env var val)
+  (if (predefined? var)
+      (set-box! (environment-cell env var) val)
+      (mapping-ref (environment-local env)
+                   var
+                   (lambda ()
+                     (hash-table-set! (environment-global env) var val))
+                   (lambda (cell)
+                     (set-box! cell val)))))
+
+(define (computation-environment-copy env)
+  (let ((global (hash-table-copy (environment-global env) #t)))
+    (mapping-for-each (lambda (var cell)
+                        (hash-table-set! global var (unbox cell)))
+                      (environment-local env))
+    (let ((new-env (make-vector (vector-length env))))
+      (environment-set-global! new-env global)
+      (environment-set-local! new-env (mapping variable-comparator))
+      (do ((i (- (vector-length env) 1) (- i 1)))
+          ((< i 2)
+           new-env)
+        (vector-set! new-env i (box (unbox (vector-ref env i))))))))
+
+(define (execute computation env)
+  (let ((coerce (if (procedure? computation)
+                    values
+                    (or (computation-environment-ref env default-computation)
+                        (error "not a computation" computation)))))
+    ((coerce computation) env)))
+
+(define (make-computation proc)
+  (lambda (env)
+    (proc (lambda (c) (execute c env)))))
+
+(define (computation-pure . args)
+  (make-computation
+   (lambda (compute)
+     (apply values args))))
+
+(define (computation-each a . a*)
+  (computation-each-in-list (cons a a*)))
+
+(define (computation-each-in-list a*)
+  (make-computation
+   (lambda (compute)
+     (let loop ((a (car a*)) (a* (cdr a*)))
+       (if (null? a*)
+           (compute a)
+           (begin
+             (compute a)
+             (loop (car a*) (cdr a*))))))))
+
+(define (computation-bind a . f*)
+  (make-computation
+   (lambda (compute)
+     (let loop ((a a) (f* f*))
+       (if (null? f*)
+           (compute a)
+           (loop (call-with-values
+                     (lambda () (compute a))
+                   (car f*))
+                 (cdr f*)))))))
+
+(define (computation-ask)
+  (lambda (env)
+    env))
+
+(define (computation-local updater computation)
+  (lambda (env)
+    (computation (updater env))))
+
+(define-syntax computation-fn
+  (syntax-rules ()
+    ((_ (clause ...) expr ... computation)
+     (%fn (clause ...) () expr ... computation))))
+
+(define-syntax %fn
+  (syntax-rules ()
+    ((_ () ((id var tmp) ...) expr ... computation)
+     (let ((tmp var) ...)
+       (computation-bind
+        (computation-ask)
+        (lambda (env)
+          (let ((id (computation-environment-ref env tmp)) ...)
+            expr ...
+            computation)))))
+    ((_ ((id var) . rest) (p ...) expr ... computation)
+     (%fn rest (p ... (id var tmp)) expr ... computation))
+    ((_ (id . rest) (p ...) expr ... computation)
+     (%fn rest (p ... (id id tmp)) expr ... computation))))
+
+(define-syntax computation-with
+  (syntax-rules ()
+    ((_ ((var val) ...) a* ... a)
+     (%with ((var val) ...) () () a* ... a))))
+
+(define-syntax %with
+  (syntax-rules ()
+    ((_ () ((x u) ...) ((a b) ...))
+     (let ((u x) ... (b a) ...)
+       (computation-local
+        (lambda (env)
+          (computation-environment-update env u ...) )
+        (computation-each b ...))))
+    ((_ ((var val) . rest) (p ...) () a* ...)
+     (%with rest (p ... (var u) (val v)) () a* ...))
+    ((_ () p* (q ...) a . a*)
+     (%with () p* (q ... (a b)) . a*))))
+
+(define-syntax computation-with!
+  (syntax-rules ()
+    ((_ (var val) ...)
+     (%with! (var val) ... ()))))
+
+(define-syntax %with!
+  (syntax-rules ()
+    ((_ ((var u val v) ...))
+     (let ((u var) ... (v val) ...)
+       (computation-bind
+        (computation-ask)
+        (lambda (env)
+          (computation-environment-update! env u v) ...
+          (computation-pure (if #f #f))))))
+    ((_ (var val) r ... (p ...))
+     (%with! r ... (p ... (var u val v))))))
+
+(define (computation-forked a . a*)
+  (make-computation
+   (lambda (compute)
+     (let loop ((a a) (a* a*))
+       (if (null? a*)
+           (compute a)
+           (begin
+             (compute (computation-local
+                       (lambda (env)
+                         (computation-environment-copy env))
+                       a))
+             (loop (car a*) (cdr a*))))))))
+
+(define (computation-bind/forked computation . proc*)
+  (apply computation-bind
+         (computation-local computation-environment-copy computation)
+         proc*))
+
+(define (computation-sequence fmt*)
+  (fold-right
+   (lambda (fmt res)
+     (computation-bind
+      res
+      (lambda (vals)
+        (computation-bind
+         fmt
+         (lambda (val)
+           (computation-pure (cons val vals)))))))
+   (computation-pure '()) fmt*))