From 9fdc4b6c283c5aa5cf10205d87fb2c58b829b9d0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 10 Jul 2022 12:39:44 +0200
Subject: [PATCH] monads: Add 'mparameterize'.

* etc/system-tests.scm (mparameterize): Move to...
* guix/monads.scm (mparameterize): ... here.
* tests/monads.scm ("mparameterize"): New test.
* .dir-locals.el (c-mode): Add it.
---
 .dir-locals.el       |  1 +
 etc/system-tests.scm | 15 ---------------
 guix/monads.scm      | 18 +++++++++++++++++-
 tests/monads.scm     | 15 ++++++++++++++-
 4 files changed, 32 insertions(+), 17 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 565f7c48e7..e4c1da8026 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -118,6 +118,7 @@
    (eval . (put 'munless 'scheme-indent-function 1))
    (eval . (put 'mlet* 'scheme-indent-function 2))
    (eval . (put 'mlet 'scheme-indent-function 2))
+   (eval . (put 'mparameterize 'scheme-indent-function 2))
    (eval . (put 'run-with-store 'scheme-indent-function 1))
    (eval . (put 'run-with-state 'scheme-indent-function 1))
    (eval . (put 'wrap-program 'scheme-indent-function 1))
diff --git a/etc/system-tests.scm b/etc/system-tests.scm
index de6f592dee..cd22b7e6d3 100644
--- a/etc/system-tests.scm
+++ b/etc/system-tests.scm
@@ -43,21 +43,6 @@ determined."
           (repository-close! repository))
         #f))))
 
-(define-syntax mparameterize
-  (syntax-rules ()
-    "This form implements dynamic scoping, similar to 'parameterize', but in a
-monadic context."
-    ((_ monad ((parameter value) rest ...) body ...)
-     (let ((old-value (parameter)))
-       (mbegin monad
-         ;; XXX: Non-local exits are not correctly handled.
-         (return (parameter value))
-         (mlet monad ((result (mparameterize monad (rest ...) body ...)))
-           (parameter old-value)
-           (return result)))))
-    ((_ monad () body ...)
-     (mbegin monad body ...))))
-
 (define (tests-for-current-guix source commit)
   "Return a list of tests for perform, using Guix built from SOURCE, a channel
 instance."
diff --git a/guix/monads.scm b/guix/monads.scm
index 6ae616aca9..0bd8ac9315 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,6 +40,7 @@
             mbegin
             mwhen
             munless
+            mparameterize
             lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
             listm
             foldm
@@ -398,6 +399,21 @@ expression."
          (mbegin %current-monad
            mexp0 mexp* ...)))))
 
+(define-syntax mparameterize
+  (syntax-rules ()
+    "This form implements dynamic scoping, similar to 'parameterize', but in a
+monadic context."
+    ((_ monad ((parameter value) rest ...) body ...)
+     (let ((old-value (parameter)))
+       (mbegin monad
+         ;; XXX: Non-local exits are not correctly handled.
+         (return (parameter value))
+         (mlet monad ((result (mparameterize monad (rest ...) body ...)))
+           (parameter old-value)
+           (return result)))))
+    ((_ monad () body ...)
+     (mbegin monad body ...))))
+
 (define-syntax define-lift
   (syntax-rules ()
     ((_ liftn (args ...))
diff --git a/tests/monads.scm b/tests/monads.scm
index 18bf4119be..19b74f4fb9 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -137,6 +137,19 @@
          %monads
          %monad-run))
 
+(test-assert "mparameterize"
+  (let ((parameter (make-parameter 'outside)))
+    (every (lambda (monad run)
+             (equal?
+              (run (mlet monad ((outer (return (parameter)))
+                                (inner
+                                 (mparameterize monad ((parameter 'inside))
+                                   (return (parameter)))))
+                     (return (list outer inner (parameter)))))
+              '(outside inside outside)))
+           %monads
+           %monad-run)))
+
 (test-assert "mlet* + text-file + package-file"
   (run-with-store %store
     (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))