Merge pull request #89 from dpk/srfis-165-166

Add SRFIs 165 and 166 (monadic formatting)

%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*))