From 405a9d4ec9806993a6453f0dfba78fc65d5e7993 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 8 Oct 2014 23:35:08 +0200
Subject: [PATCH] monads: Add 'mbegin'.

* guix/monads.scm (mbegin): New macro.
* tests/monads.scm ("mbegin"): New test.
* doc/guix.texi (The Store Monad): Document it.
---
 .dir-locals.el   |  1 +
 doc/guix.texi    |  9 +++++++++
 guix/monads.scm  | 14 ++++++++++++++
 tests/monads.scm | 17 ++++++++++++++++-
 4 files changed, 40 insertions(+), 1 deletion(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index edc964123f..6cd55e7788 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -38,6 +38,7 @@
 
    (eval . (put 'syntax-parameterize 'scheme-indent-function 1))
    (eval . (put 'with-monad 'scheme-indent-function 1))
+   (eval . (put 'mbegin 'scheme-indent-function 1))
    (eval . (put 'mlet* 'scheme-indent-function 2))
    (eval . (put 'mlet 'scheme-indent-function 2))
    (eval . (put 'run-with-store 'scheme-indent-function 1))
diff --git a/doc/guix.texi b/doc/guix.texi
index ed2b81ba33..c9760f5f60 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2061,6 +2061,15 @@ Bind the variables @var{var} to the monadic values @var{mval} in
 (@pxref{Local Bindings,,, guile, GNU Guile Reference Manual}).
 @end deffn
 
+@deffn {Scheme System} mbegin @var{monad} @var{mexp} ...
+Bind @var{mexp} and the following monadic expressions in sequence,
+returning the result of the last expression.
+
+This is akin to @code{mlet}, except that the return values of the
+monadic expressions are ignored.  In that sense, it is analogous to
+@code{begin}, but applied to monadic expressions.
+@end deffn
+
 The interface to the store monad provided by @code{(guix monads)} is as
 follows.
 
diff --git a/guix/monads.scm b/guix/monads.scm
index 2ab3fb94f0..d9580a7f8e 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -38,6 +38,7 @@
             with-monad
             mlet
             mlet*
+            mbegin
             lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
             listm
             foldm
@@ -171,6 +172,19 @@ form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
              (let ((var temp) ...)
                body ...)))))))
 
+(define-syntax mbegin
+  (syntax-rules ()
+    "Bind the given monadic expressions in sequence, returning the result of
+the last one."
+    ((_ monad mexp)
+     (with-monad monad
+       mexp))
+    ((_ monad mexp rest ...)
+     (with-monad monad
+       (>>= mexp
+            (lambda (unused-value)
+              (mbegin monad rest ...)))))))
+
 (define-syntax define-lift
   (syntax-rules ()
     ((_ liftn (args ...))
diff --git a/tests/monads.scm b/tests/monads.scm
index 5514c8386c..6e3dd00f72 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -32,7 +32,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64))
 
-;; Test the (guix store) module.
+;; Test the (guix monads) module.
 
 (define %store
   (open-connection-for-tests))
@@ -99,6 +99,21 @@
          %monads
          %monad-run))
 
+(test-assert "mbegin"
+  (every (lambda (monad run)
+           (with-monad monad
+             (let* ((been-there? #f)
+                    (number (mbegin monad
+                              (return 1)
+                              (begin
+                                (set! been-there? #t)
+                                (return 2))
+                              (return 3))))
+               (and (= (run number) 3)
+                    been-there?))))
+         %monads
+         %monad-run))
+
 (test-assert "mlet* + text-file + package-file"
   (run-with-store %store
     (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))