gexp: ‘with-parameters’ properly handles ‘%graft?’.

Fixes <https://issues.guix.gnu.org/75879>.

* .dir-locals.el (scheme-mode): Remove mparameterize indentation rules.
Add state-parameterize and store-parameterize indentation rules.
* etc/manifests/system-tests.scm (test-for-current-guix): Replace
mparameterize with store-parameterize.
* etc/manifests/time-travel.scm (guix-instance-compiler): Likewise.
* gnu/tests.scm (compile-system-test): Likewise.
* guix/gexp.scm (compile-parameterized): Use state-call-with-parameters.
* guix/monads.scm (mparameterize): Remove macro.
(state-call-with-parameters): New procedure.
(state-parameterize): New macro.
* guix/store.scm (store-parameterize): New macro.
* tests/gexp.scm ("with-parameters for %graft?"): New test.
* tests/monads.scm ("mparameterize"): Remove test.
("state-parameterize"): New test.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
Change-Id: I0c74066ca3f37072815b073fb3039925488a9645
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

9 files changed, 114 insertions, 59 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index d629b51c8a1..76c9e12992a 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -138,7 +138,8 @@
    (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 'state-parameterize 'scheme-indent-function 2))
+   (eval . (put 'store-parameterize '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/manifests/system-tests.scm b/etc/manifests/system-tests.scm
index 4e16c53dcfc..430f5075207 100644
--- a/etc/manifests/system-tests.scm
+++ b/etc/manifests/system-tests.scm
@@ -53,7 +53,7 @@ instance."
     (map (lambda (test)
            (system-test
             (inherit test)
-            (value (mparameterize %store-monad ((current-guix-package guix))
+            (value (store-parameterize ((current-guix-package guix))
                      (system-test-value test)))))
          (match (getenv "TESTS")
            (#f
diff --git a/etc/manifests/time-travel.scm b/etc/manifests/time-travel.scm
index 039ca89889d..5256d2195c2 100644
--- a/etc/manifests/time-travel.scm
+++ b/etc/manifests/time-travel.scm
@@ -22,7 +22,7 @@
 (use-modules (srfi srfi-9) (ice-9 match)
              (guix channels) (guix gexp)
              ((guix store) #:select (%store-monad))
-             ((guix monads) #:select (mparameterize return))
+             ((guix monads) #:select (store-parameterize return))
              ((guix git) #:select (%repository-cache-directory))
              ((guix build utils) #:select (mkdir-p)))
 
@@ -40,9 +40,9 @@
      ;; When this manifest is evaluated by Cuirass, make sure it does not
      ;; fiddle with the cached checkout that Cuirass is also using since
      ;; concurrent accesses are unsafe.
-     (mparameterize %store-monad ((%repository-cache-directory
-                                   (string-append (%repository-cache-directory)
-                                                  "/time-travel/" system)))
+     (store-parameterize ((%repository-cache-directory
+                           (string-append (%repository-cache-directory)
+                                          "/time-travel/" system)))
        (return (mkdir-p (%repository-cache-directory)))
        (latest-channel-derivation channels)))))
 
diff --git a/gnu/tests.scm b/gnu/tests.scm
index 2a9e51511f0..1e3dbf09445 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -34,7 +34,7 @@
   #:use-module (gnu services shepherd)
   #:use-module (guix discovery)
   #:use-module (guix monads)
-  #:use-module ((guix store) #:select (%store-monad))
+  #:use-module ((guix store) #:select (%store-monad store-parameterize))
   #:use-module ((guix utils)
                 #:select (%current-system %current-target-system))
   #:use-module (srfi srfi-1)
@@ -289,9 +289,9 @@ the system under test."
 (define-gexp-compiler (compile-system-test (test <system-test>)
                                            system target)
   "Compile TEST to a derivation."
-  (mparameterize %store-monad ((%current-system system)
-                               (%current-target-system target))
-    (system-test-value test)))
+  (store-parameterize ((%current-system system)
+                       (%current-target-system target))
+      (system-test-value test)))
 
 (define (test-modules)
   "Return the list of modules that define system tests."
diff --git a/guix/gexp.scm b/guix/gexp.scm
index ad51bc55b78..9ce6810172b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -733,26 +733,28 @@ x86_64-linux when COREUTILS is lowered."
   (lambda (parameterized system target)
     (match (parameterized-bindings parameterized)
       (((parameters values) ...)
-       (let ((fluids (map parameter-fluid parameters))
-             (thunk  (parameterized-thunk parameterized)))
-         ;; Install the PARAMETERS for the dynamic extent of THUNK.
-         (with-fluids* fluids
-           (map (lambda (thunk) (thunk)) values)
-           (lambda ()
-             ;; Special-case '%current-system' and '%current-target-system' to
-             ;; make sure we get the desired effect.
-             (let ((system (if (memq %current-system parameters)
-                               (%current-system)
-                               system))
-                   (target (if (memq %current-target-system parameters)
-                               (%current-target-system)
-                               target)))
-               (match (thunk)
-                 ((? struct? obj)
-                  (lower-object obj system #:target target))
-                 (obj                             ;store item
-                  (with-monad %store-monad
-                    (return obj)))))))))))
+       (let ((thunk (parameterized-thunk parameterized))
+             (values (map (lambda (thunk) (thunk)) values)))
+         ;; Install the PARAMETERS for the store monad.
+         (state-with-parameters parameters values
+           ;; Install the PARAMETERS for the dynamic extent of THUNK.
+           ;; Special-case '%current-system' and '%current-target-system' to
+           ;; make sure we get the desired effect.
+           (with-fluids* (map parameter-fluid parameters)
+             values
+             (lambda ()
+               (let ((system (if (memq %current-system parameters)
+                                 (%current-system)
+                                 system))
+                     (target (if (memq %current-target-system parameters)
+                                 (%current-target-system)
+                                 target)))
+                 (match (thunk)
+                   ((? struct? obj)
+                    (lower-object obj system #:target target))
+                   (obj                             ;store item
+                    (with-monad %store-monad
+                      (return obj))))))))))))
 
   expander => (lambda (parameterized lowered output)
                 (match (parameterized-bindings parameterized)
diff --git a/guix/monads.scm b/guix/monads.scm
index 0bd8ac9315d..e1b056dc95f 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2015, 2017, 2022, 2025 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2025 David Elsing <david.elsing@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +20,7 @@
 (define-module (guix monads)
   #:use-module ((system syntax)
                 #:select (syntax-local-binding))
+  #:autoload   (guix deprecation) (warn-about-deprecation)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -40,7 +42,6 @@
             mbegin
             mwhen
             munless
-            mparameterize
             lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
             listm
             foldm
@@ -58,7 +59,9 @@
             set-current-state
             state-push
             state-pop
-            run-with-state))
+            run-with-state
+            state-parameterize
+            mparameterize))
 
 ;;; Commentary:
 ;;;
@@ -399,21 +402,6 @@ 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 ...))
@@ -600,4 +588,48 @@ the previous state as a monadic value."
   (lambda (state)
     (values state (cons value state))))
 
+(define-public (state-with-parameters parameters parameter-values mval)
+  "Set PARAMETERS to PARAMETER-VALUES for the dynamic extent of MVAL, a value
+in the state monad."
+  (define (set-value parameter value)
+    (parameter value))
+
+  (lambda (state)
+    ;; XXX: 'with-fluids*' does not work with prompts, therefore the parameters
+    ;; are set globally. This leaves the parameters changed upon a non-local
+    ;; exit and restores them only after running MVAL to completion. See
+    ;; <https://issues.guix.gnu.org/76485>.
+    (let ((old-values (map set-value parameters parameter-values)))
+      (call-with-values
+          (lambda ()
+            (mval state))
+        (lambda (value state)
+          (map set-value parameters old-values)
+          (values value state))))))
+
+(define-syntax state-parameterize
+  (syntax-rules ()
+    "This form implements dynamic scoping, similar to 'parameterize', but also
+in the monadic context of the state monad."
+    ((_ ((param value) ...) body ...)
+     (let ((parameters (list param ...))
+           (values (list value ...)))
+       (state-with-parameters parameters values
+         ;; Install the parameters also for the evaluation of body ...
+         (with-fluids* (map parameter-fluid parameters)
+           values
+           (lambda ()
+             (mbegin %state-monad body ...))))))))
+
+(define-syntax mparameterize                  ;can be removed after 2026-03-05
+  (lambda (s)
+    "This is the old form for 'state-parameterize', which pretended to work
+with any monad but was in fact specialized for '%state-monad'."
+    (syntax-case s ()
+      ((_ monad bindings body ...)
+       (begin
+         (warn-about-deprecation 'mparameterize (current-source-location)
+                                 #:replacement 'state-parameterize)
+         #'(state-parameterize bindings body ...))))))
+
 ;;; monads.scm end here
diff --git a/guix/store.scm b/guix/store.scm
index cf5848e580b..bae8e7762b0 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -178,6 +178,7 @@
             store-lift
             store-lower
             run-with-store
+            store-parameterize
             %guile-for-build
             current-system
             set-current-system
@@ -1919,6 +1920,7 @@ This is a mutating version that should be avoided.  Prefer the functional
 (define-alias %store-monad %state-monad)
 (define-alias store-return state-return)
 (define-alias store-bind state-bind)
+(define-alias store-parameterize state-parameterize)
 
 ;; Instantiate templates for %STORE-MONAD since it's syntactically different
 ;; from %STATE-MONAD.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index e870f6cb1b9..2376c70d1ba 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -451,6 +451,26 @@
     (return (string=? (derivation-file-name drv)
                       (derivation-file-name result)))))
 
+(test-assertm "with-parameters for %graft?"
+  (mlet* %store-monad ((replacement -> (package
+                                         (inherit %bootstrap-guile)
+                                         (name (string-upcase
+                                                (package-name
+                                                 %bootstrap-guile)))))
+                       (guile -> (package
+                                   (inherit %bootstrap-guile)
+                                   (replacement replacement)))
+                       (drv0   (package->derivation %bootstrap-guile))
+                       (drv1   (package->derivation replacement))
+                       (obj0 -> (with-parameters ((%graft? #f))
+                                  guile))
+                       (obj1 -> (with-parameters ((%graft? #t))
+                                  guile))
+                       (result0 (lower-object obj0))
+                       (result1 (lower-object obj1)))
+    (return (and (eq? drv0 result0)
+                 (eq? drv1 result1)))))
+
 (test-assert "with-parameters + file-append"
   (let* ((system (match (%current-system)
                    ("aarch64-linux" "x86_64-linux")
diff --git a/tests/monads.scm b/tests/monads.scm
index 7f255f02bf5..c05d13776a5 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -136,18 +136,16 @@
          %monads
          %monad-run))
 
-(test-assert "mparameterize"
+(test-assert "state-parameterize"
   (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)))
+    (equal?
+     (run-with-state
+         (mlet %state-monad ((outer (return (parameter)))
+                             (inner
+                              (state-parameterize ((parameter 'inside))
+                                  (return (parameter)))))
+           (return (list outer inner (parameter)))))
+     '(outside inside outside))))
 
 (test-assert "mlet* + text-file + package-file"
   (run-with-store %store