From 751630c9c3f7f3e87dfccc5f5ba8cf61cdd6f8fd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 8 Jun 2015 22:49:50 +0200
Subject: [PATCH] monads: Allow n-ary '>>=' expressions.

Suggested by Federico Beffa <beffa@fbengineering.ch>.

* guix/monads.scm (bind-syntax): New macro.
  (with-monad): Use it instead of 'identifier-syntax'.
* tests/monads.scm (">>= with more than two arguments"): New test.
* doc/guix.texi (The Store Monad): Explain that there can be several MPROC.
  Add an example.
---
 doc/guix.texi    | 23 ++++++++++++++++++-----
 guix/monads.scm  | 27 +++++++++++++++++++++++++--
 tests/monads.scm | 13 +++++++++++++
 3 files changed, 56 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index bcfa52d5b1..85ccd4057e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2773,12 +2773,25 @@ in @var{monad}.
 Return a monadic value that encapsulates @var{val}.
 @end deffn
 
-@deffn {Scheme Syntax} >>= @var{mval} @var{mproc}
+@deffn {Scheme Syntax} >>= @var{mval} @var{mproc} ...
 @dfn{Bind} monadic value @var{mval}, passing its ``contents'' to monadic
-procedure @var{mproc}@footnote{This operation is commonly referred to as
-``bind'', but that name denotes an unrelated procedure in Guile.  Thus
-we use this somewhat cryptic symbol inherited from the Haskell
-language.}.
+procedures @var{mproc}@dots{}@footnote{This operation is commonly
+referred to as ``bind'', but that name denotes an unrelated procedure in
+Guile.  Thus we use this somewhat cryptic symbol inherited from the
+Haskell language.}.  There can be one @var{mproc} or several of them, as
+in this example:
+
+@example
+(run-with-state
+    (with-monad %state-monad
+      (>>= (return 1)
+           (lambda (x) (return (+ 1 x)))
+           (lambda (x) (return (* 2 x)))))
+  'some-state)
+
+@result{} 4
+@result{} some-state
+@end example
 @end deffn
 
 @deffn {Scheme Syntax} mlet @var{monad} ((@var{var} @var{mval}) ...) @
diff --git a/guix/monads.scm b/guix/monads.scm
index 4248525433..2196a9c991 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -112,6 +112,29 @@
   (lambda (s)
     (syntax-violation 'return "return used outside of 'with-monad'" s)))
 
+(define-syntax-rule (bind-syntax bind)
+  "Return a macro transformer that handles the expansion of '>>=' expressions
+using BIND as the binary bind operator.
+
+This macro exists to allow the expansion of n-ary '>>=' expressions, even
+though BIND is simply binary, as in:
+
+  (with-monad %state-monad
+    (>>= (return 1)
+         (lift 1+ %state-monad)
+         (lift 1+ %state-monad)))
+"
+  (lambda (stx)
+    (define (expand body)
+      (syntax-case body ()
+        ((_ mval mproc)
+         #'(bind mval mproc))
+        ((x mval mproc0 mprocs (... ...))
+         (expand #'(>>= (>>= mval mproc0)
+                        mprocs (... ...))))))
+
+    (expand stx)))
+
 (define-syntax with-monad
   (lambda (s)
     "Evaluate BODY in the context of MONAD, and return its result."
@@ -120,13 +143,13 @@
        (eq? 'macro (syntax-local-binding #'monad))
        ;; MONAD is a syntax transformer, so we can obtain the bind and return
        ;; methods by directly querying it.
-       #'(syntax-parameterize ((>>=    (identifier-syntax (monad %bind)))
+       #'(syntax-parameterize ((>>=    (bind-syntax (monad %bind)))
                                (return (identifier-syntax (monad %return))))
            body ...))
       ((_ monad body ...)
        ;; MONAD refers to the <monad> record that represents the monad at run
        ;; time, so use the slow method.
-       #'(syntax-parameterize ((>>=    (identifier-syntax
+       #'(syntax-parameterize ((>>=    (bind-syntax
                                         (monad-bind monad)))
                                (return (identifier-syntax
                                         (monad-return monad))))
diff --git a/tests/monads.scm b/tests/monads.scm
index 5529a6188a..d3ef065f24 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -103,6 +103,19 @@
          %monads
          %monad-run))
 
+(test-assert ">>= with more than two arguments"
+  (every (lambda (monad run)
+           (let ((1+ (lift1 1+ monad))
+                 (2* (lift1 (cut * 2 <>) monad)))
+             (with-monad monad
+               (let ((number (random 777)))
+                 (= (run (>>= (return number)
+                              1+ 1+ 1+
+                              2* 2* 2*))
+                    (* 8 (+ number 3)))))))
+         %monads
+         %monad-run))
+
 (test-assert "mbegin"
   (every (lambda (monad run)
            (with-monad monad