monads: Add the state monad.

* guix/monads.scm (state-return, state-bind, run-with-state,
  current-state, set-current-state, state-push, state-pop): New
  procedures.
  (%state-monad): New variable.
* tests/monads.scm (%monads): Add %STATE-MONAD.
  (%monad-run): Add 'run-with-state'.
  (values->list): New macro.
  ("set-current-state", "state-push etc."): New tests.

1 files changed, 33 insertions, 2 deletions

diff --git a/tests/monads.scm b/tests/monads.scm
index 347a255072..57a8e66797 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -37,11 +37,16 @@
   (open-connection-for-tests))
 
 (define %monads
-  (list %identity-monad %store-monad))
+  (list %identity-monad %store-monad %state-monad))
 
 (define %monad-run
   (list identity
-        (cut run-with-store %store <>)))
+        (cut run-with-store %store <>)
+        (cut run-with-state <> '())))
+
+(define-syntax-rule (values->list exp)
+  (call-with-values (lambda () exp)
+    list))
 
 
 (test-begin "monads")
@@ -206,6 +211,32 @@
          %monads
          %monad-run))
 
+(test-equal "set-current-state"
+  (list '(a a d) 'd)
+  (values->list
+   (run-with-state
+       (mlet* %state-monad ((init  (current-state))
+                            (init2 (set-current-state 'b)))
+         (mbegin %state-monad
+           (set-current-state 'c)
+           (set-current-state 'd)
+           (mlet %state-monad ((last (current-state)))
+             (return (list init init2 last)))))
+     'a)))
+
+(test-equal "state-push etc."
+  (list '((z . 2) (p . (1)) (a . (1))) '(2 1))
+  (values->list
+   (run-with-state
+       (mbegin %state-monad
+         (state-push 1)    ;(1)
+         (state-push 2)    ;(2 1)
+         (mlet* %state-monad ((z (state-pop))        ;(1)
+                              (p (current-state))
+                              (a (state-push z)))    ;(2 1)
+           (return `((z . ,z) (p . ,p) (a . ,a)))))
+     '())))
+
 (test-end "monads")