01/03: monads: Allow n-ary '>>=' expressions.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 751630c9c3f7f3e87dfccc5f5ba8cf61cdd6f8fd
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jun 8 22:49:50 2015 +0200

    monads: Allow n-ary '>>=' expressions.
    
    Suggested by Federico Beffa <address@hidden>.
    
    * 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 bcfa52d..85ccd40 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
 
address@hidden {Scheme Syntax} >>= @var{mval} @var{mproc}
address@hidden {Scheme Syntax} >>= @var{mval} @var{mproc} ...
 @dfn{Bind} monadic value @var{mval}, passing its ``contents'' to monadic
-procedure @address@hidden 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 @address@hidden@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:
+
address@hidden
+(run-with-state
+    (with-monad %state-monad
+      (>>= (return 1)
+           (lambda (x) (return (+ 1 x)))
+           (lambda (x) (return (* 2 x)))))
+  'some-state)
+
address@hidden 4
address@hidden some-state
address@hidden example
 @end deffn
 
 @deffn {Scheme Syntax} mlet @var{monad} ((@var{var} @var{mval}) ...) @
diff --git a/guix/monads.scm b/guix/monads.scm
index 4248525..2196a9c 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 5529a61..d3ef065 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