From 21caa6deebee28f07467c5fd1dcd5b8997393ca4 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 2 Dec 2014 10:11:11 +0100
Subject: monads: Add 'mwhen' and 'munless'.

* guix/monads.scm (mbegin): Add special '%current-monad' syntactic
  keyword.
  (mwhen, munless): New macros.
---
 .dir-locals.el  |  2 ++
 guix/monads.scm | 30 +++++++++++++++++++++++++++++-
 2 files changed, 31 insertions(+), 1 deletion(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 106c35bce6..b099068dac 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -46,6 +46,8 @@
    (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 'mwhen 'scheme-indent-function 1))
+   (eval . (put 'munless '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/guix/monads.scm b/guix/monads.scm
index b419ba066a..52cb3f5ed0 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -39,6 +39,8 @@ (define-module (guix monads)
             mlet
             mlet*
             mbegin
+            mwhen
+            munless
             lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
             listm
             foldm
@@ -173,9 +175,15 @@ (define-syntax mlet
                body ...)))))))
 
 (define-syntax mbegin
-  (syntax-rules ()
+  (syntax-rules (%current-monad)
     "Bind the given monadic expressions in sequence, returning the result of
 the last one."
+    ((_ %current-monad mexp)
+     mexp)
+    ((_ %current-monad mexp rest ...)
+     (>>= mexp
+          (lambda (unused-value)
+            (mbegin %current-monad rest ...))))
     ((_ monad mexp)
      (with-monad monad
        mexp))
@@ -185,6 +193,26 @@ (define-syntax mbegin
             (lambda (unused-value)
               (mbegin monad rest ...)))))))
 
+(define-syntax mwhen
+  (syntax-rules ()
+    "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'.  When
+CONDITION is false, return *unspecified* in the current monad."
+    ((_ condition exp0 exp* ...)
+     (if condition
+         (mbegin %current-monad
+           exp0 exp* ...)
+         (return *unspecified*)))))
+
+(define-syntax munless
+  (syntax-rules ()
+    "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'.  When
+CONDITION is true, return *unspecified* in the current monad."
+    ((_ condition exp0 exp* ...)
+     (if condition
+         (return *unspecified*)
+         (mbegin %current-monad
+           exp0 exp* ...)))))
+
 (define-syntax define-lift
   (syntax-rules ()
     ((_ liftn (args ...))
-- 
cgit v1.2.3