From 81a97734e04fa40412b2d44ccfae1b4796257648 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 17 Jan 2015 18:46:41 +0100
Subject: 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.
---
 .dir-locals.el   |  1 +
 guix/monads.scm  | 65 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 tests/monads.scm | 35 ++++++++++++++++++++++++++++--
 3 files changed, 98 insertions(+), 3 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index b099068dac..b82d0494e4 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -51,6 +51,7 @@
    (eval . (put 'mlet* 'scheme-indent-function 2))
    (eval . (put 'mlet 'scheme-indent-function 2))
    (eval . (put 'run-with-store 'scheme-indent-function 1))
+   (eval . (put 'run-with-state 'scheme-indent-function 1))
 
    ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols.
    ;; This notably allows '(' in Paredit to not insert a space when the
diff --git a/guix/monads.scm b/guix/monads.scm
index 7fec3d5168..f97f4add5d 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -46,7 +46,16 @@
             anym
 
             ;; Concrete monads.
-            %identity-monad))
+            %identity-monad
+
+            %state-monad
+            state-return
+            state-bind
+            current-state
+            set-current-state
+            state-push
+            state-pop
+            run-with-state))
 
 ;;; Commentary:
 ;;;
@@ -291,4 +300,58 @@ lifted in MONAD, for which PROC returns true."
   (bind   identity-bind)
   (return identity-return))
 
+
+;;;
+;;; State monad.
+;;;
+
+(define-inlinable (state-return value)
+  (lambda (state)
+    (values value state)))
+
+(define-inlinable (state-bind mvalue mproc)
+  "Bind MVALUE, a value in the state monad, and pass it to MPROC."
+  (lambda (state)
+    (call-with-values
+        (lambda ()
+          (mvalue state))
+      (lambda (value state)
+        ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
+        ;; of (mproc value) prevents a bit of unfolding/inlining.
+        ((mproc value) state)))))
+
+(define-monad %state-monad
+  (bind state-bind)
+  (return state-return))
+
+(define* (run-with-state mval #:optional (state '()))
+  "Run monadic value MVAL starting with STATE as the initial state.  Return
+two values: the resulting value, and the resulting state."
+  (mval state))
+
+(define-inlinable (current-state)
+  "Return the current state as a monadic value."
+  (lambda (state)
+    (values state state)))
+
+(define-inlinable (set-current-state value)
+  "Set the current state to VALUE and return the previous state as a monadic
+value."
+  (lambda (state)
+    (values state value)))
+
+(define (state-pop)
+  "Pop a value from the current state and return it as a monadic value.  The
+state is assumed to be a list."
+  (lambda (state)
+    (match state
+      ((head . tail)
+       (values head tail)))))
+
+(define (state-push value)
+  "Push VALUE to the current state, which is assumed to be a list, and return
+the previous state as a monadic value."
+  (lambda (state)
+    (values state (cons value state))))
+
 ;;; monads.scm end here
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")
 
 
-- 
cgit v1.2.3