Borrow state-monad from guile-dns.

Also imports the tests from guile-dns. Minor rewrites have been done, to
match a differing project structure.

3 files changed, 341 insertions, 0 deletions

diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm
new file mode 100644
index 00000000..67716a5b
--- /dev/null
+++ b/module/hnh/util/state-monad.scm
@@ -0,0 +1,100 @@
+;;; Commentary:
+;;; A state monad similar to (and directly influenced by) the one found in in
+;;; Haskell
+;;; Each procedure can either explicitly take the state as a curried last
+;;; argument, or use the `do' notation, which handles that implicitly.
+;;; Each procedure MUST return two values, where the second value is the state
+;;; value which will be chained.
+;;;
+;;; Code borrowed from guile-dns
+;;; Code:
+
+(define-module (hnh util state-monad)
+  :use-module (ice-9 curried-definitions)
+  :replace (do mod)
+  :export (with-temp-state
+           <$> return get get* put put* sequence lift))
+
+(define-syntax do
+  (syntax-rules (<- let =)
+    ((_ (a ...) <- b rest ...)
+     (lambda state-args
+       (call-with-values (lambda () (apply b state-args))
+                         (lambda (a* . next-state)
+                           (apply (lambda (a ...)
+                                    (apply (do rest ...)
+                                           next-state))
+                                  a*)))))
+    ((_ a <- b rest ...)
+     (lambda state-args
+       (call-with-values (lambda () (apply b state-args))
+                         (lambda (a . next-state)
+                           (apply (do rest ...)
+                                  next-state)))))
+
+    ((_ a = b rest ...)
+     (let ((a b))
+       (do rest ...)))
+
+    ((_ a)
+     (lambda state (apply a state)))
+    ((_ a rest ...)
+     (lambda state
+       (call-with-values (lambda () (apply a state))
+                         (lambda (_ . next-state)
+                           (apply (do rest ...)
+                            next-state)))))))
+
+
+(define (with-temp-state state* op)
+  (do old <- (get*)
+      (apply put* state*)
+      ret-value <- op
+      (apply put* old)
+      (return ret-value)))
+
+
+(define (<$> f y)
+  (do tmp <- y
+      (return (f tmp))))
+
+(define ((return x) . y)
+  (apply values x y))
+
+(define ((get*) . state)
+  "Like @code{get}, but always returns a list"
+  (values state state))
+
+(define ((get) fst . state)
+  "If state contains a single variable return that, otherwise, return a list of all variables in state"
+  (if (null? state)
+      (values fst fst)
+      (apply values (cons fst state) fst state)))
+
+(define ((put . new-state) fst . old-state)
+  (if (null? old-state)
+      (apply values fst new-state)
+      (apply values (cons fst old-state) new-state)))
+
+;; Like put, but doesn't return anything (useful)
+(define ((put* . new-state) . _)
+  (apply values #f new-state))
+
+(define (mod proc)
+  (do
+    a <- (get)
+    (put (proc a))))
+
+;; ms must be a list of continuations
+(define (sequence ms)
+  (if (null? ms)
+    (return '())
+    (do
+      fst <- (car ms)
+      rest <- (sequence (cdr ms))
+      (return (cons fst rest)))))
+
+
+(define (lift proc . arguments)
+  (do xs <- (sequence arguments)
+      (return (apply proc xs))))
diff --git a/tests/test/hnh-util-state-monad.scm b/tests/test/hnh-util-state-monad.scm
new file mode 100644
index 00000000..353c47e9
--- /dev/null
+++ b/tests/test/hnh-util-state-monad.scm
@@ -0,0 +1,120 @@
+(define-module (test hnh-util-state-monad)
+  :use-module (srfi srfi-64)
+  :use-module (hnh util state-monad))
+
+
+(call-with-values (lambda () ((return 1) 2))
+  (lambda (value state)
+    (test-equal "Return returns the value unmodified" 1 value)
+    (test-equal "Return also returns the state as a second value" 2 state)))
+
+(test-equal "Get returns the current state as primary value, while kepping the state"
+  '(state state)
+  (call-with-values (lambda () ((get) 'state)) list))
+
+;; Return value of put untested, since it's undefined
+(test-equal "Put replaces the old state with a new one, and return old one"
+  '(old-state new-state)
+  (call-with-values (lambda () ((put 'new-state) 'old-state))
+    list))
+
+(test-equal "A simple do is effectively a `values' call"
+  '(value initial-state)
+  (call-with-values (lambda () ((do (return 'value)) 'initial-state))
+    list))
+
+(test-equal "Let statement in do"
+  '(10 state)
+  (call-with-values (lambda () ((do x = 10
+                                  (return x))
+                                'state))
+                    list))
+
+;; TODO let statement with multiple binds
+;; (do let (a b) = (values 10 20) ...)
+
+(test-equal "Set and get through do, along with <- in do."
+  '(5 1)
+  (call-with-values (lambda () ((do old <- (get)
+                               (put (1+ old))
+                               (return 5))
+                           0))
+    list))
+
+
+
+(test-equal "<$> Updates stuff before being removed from the monad context"
+    '(11 10)
+ (call-with-values (lambda ()
+                     ((do x <- (<$> 1+ (get))
+                          (return x))
+                      10))
+   list))
+
+(test-equal "Sequence should update the state accordingly"
+  3
+  (call-with-values
+      (lambda ()
+        ((sequence
+           (list (mod 1+)
+                 (mod 1+)
+                 (mod 1+)))
+         0))
+    (lambda (_ st) st)))
+
+(test-equal "Sequence should also act as map on the primary value"
+  '((0 1 2) 3)
+  (call-with-values
+      (lambda ()
+        ((sequence
+           (list (mod 1+)
+                 (mod 1+)
+                 (mod 1+)))
+         0))
+    list))
+
+(test-equal "Get returns a single value when only a single value is in the state"
+  '(1 1) (call-with-values (lambda () ((get) 1))
+           list))
+
+(test-equal "Get returns a list of values when multiple items are in the state"
+  '((1 2 3) 1 2 3)
+  (call-with-values (lambda ()  ((get) 1 2 3))
+    list))
+
+(test-equal "Get with multiple values"
+  '((1 2) 1 2)
+  (call-with-values (lambda () ((get) 1 2))
+    list))
+
+(test-equal "Get with multiple values in do"
+  '((1 2) 1 2)
+  (call-with-values (lambda ()
+                     ((do (a b) <- (get)
+                          (return (list a b)))
+                      1 2))
+    list))
+
+((do (put 0)
+     (with-temp-state
+      (list 10)
+      (do a <- (get)
+          (return (test-equal "Temporary state is set"
+                    10 a))
+          (put 20)))
+   a <- (get)
+   (return (test-equal "Pre-temp state is restored" 0 a)))
+ 'init)
+
+
+;; TODO test for do where the number of implicit arguments changes
+
+(test-equal "Something" 30
+            ((do (with-temp-state
+                  '(10 20)
+                  ;; todo (lift +)
+                  (do (a b) <- (get)
+                      (return (+ a b)))))
+             0 1))
+
+
diff --git a/tests/test/state-monad.scm b/tests/test/state-monad.scm
new file mode 100644
index 00000000..a4e28b78
--- /dev/null
+++ b/tests/test/state-monad.scm
@@ -0,0 +1,121 @@
+;;; Borrowed from guile-dns
+
+(define-module (test state-monad)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util state-monad)
+  )
+
+(call-with-values (lambda () ((return 1) 2))
+  (lambda (value state)
+    (test-equal "Return returns the value unmodified" 1 value)
+    (test-equal "Return also returns the state as a second value" 2 state)))
+
+(test-equal "Get returns the current state as primary value, while kepping the state"
+  '(state state)
+  (call-with-values (lambda () ((get) 'state)) list))
+
+;; Return value of put untested, since it's undefined
+(test-equal "Put replaces the old state with a new one, and return old one"
+  '(old-state new-state)
+  (call-with-values (lambda () ((put 'new-state) 'old-state))
+    list))
+
+(test-equal "A simple do is effectively a `values' call"
+  '(value initial-state)
+  (call-with-values (lambda () ((do (return 'value)) 'initial-state))
+    list))
+
+(test-equal "Let statement in do"
+  '(10 state)
+  (call-with-values (lambda () ((do x = 10
+                                  (return x))
+                                'state))
+                    list))
+
+;; TODO let statement with multiple binds
+;; (do let (a b) = (values 10 20) ...)
+
+(test-equal "Set and get through do, along with <- in do."
+  '(5 1)
+  (call-with-values (lambda () ((do old <- (get)
+                               (put (1+ old))
+                               (return 5))
+                           0))
+    list))
+
+
+
+(test-equal "<$> Updates stuff before being removed from the monad context"
+    '(11 10)
+ (call-with-values (lambda ()
+                     ((do x <- (<$> 1+ (get))
+                          (return x))
+                      10))
+   list))
+
+(test-equal "Sequence should update the state accordingly"
+  3
+  (call-with-values
+      (lambda ()
+        ((sequence
+           (list (mod 1+)
+                 (mod 1+)
+                 (mod 1+)))
+         0))
+    (lambda (_ st) st)))
+
+(test-equal "Sequence should also act as map on the primary value"
+  '((0 1 2) 3)
+  (call-with-values
+      (lambda ()
+        ((sequence
+           (list (mod 1+)
+                 (mod 1+)
+                 (mod 1+)))
+         0))
+    list))
+
+(test-equal "Get returns a single value when only a single value is in the state"
+  '(1 1) (call-with-values (lambda () ((get) 1))
+           list))
+
+(test-equal "Get returns a list of values when multiple items are in the state"
+  '((1 2 3) 1 2 3)
+  (call-with-values (lambda ()  ((get) 1 2 3))
+    list))
+
+(test-equal "Get with multiple values"
+  '((1 2) 1 2)
+  (call-with-values (lambda () ((get) 1 2))
+    list))
+
+(test-equal "Get with multiple values in do"
+  '((1 2) 1 2)
+  (call-with-values (lambda ()
+                     ((do (a b) <- (get)
+                          (return (list a b)))
+                      1 2))
+    list))
+
+((do (put 0)
+     (with-temp-state
+      (list 10)
+      (do a <- (get)
+          (return (test-equal "Temporary state is set"
+                    10 a))
+          (put 20)))
+   a <- (get)
+   (return (test-equal "Pre-temp state is restored" 0 a)))
+ 'init)
+
+
+;; TODO test for do where the number of implicit arguments changes
+
+(test-equal "Something" 30
+            ((do (with-temp-state
+                  '(10 20)
+                  ;; todo (lift +)
+                  (do (a b) <- (get)
+                      (return (+ a b)))))
+             0 1))