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 edc964123fc..6cd55e7788e 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 ed2b81ba33e..c9760f5f60e 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 2ab3fb94f03..d9580a7f8ec 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -38,6 +38,7 @@ (define-module (guix monads)
with-monad
mlet
mlet*
+ mbegin
lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
listm
foldm
@@ -171,6 +172,19 @@ (define-syntax mlet
(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 5514c8386c7..6e3dd00f724 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -32,7 +32,7 @@ (define-module (test-monads)
#: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 @@ (define (g x)
%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"))
--
GitLab