summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.dir-locals.el3
-rw-r--r--etc/manifests/system-tests.scm2
-rw-r--r--etc/manifests/time-travel.scm8
-rw-r--r--gnu/tests.scm8
-rw-r--r--guix/gexp.scm42
-rw-r--r--guix/monads.scm68
-rw-r--r--guix/store.scm2
-rw-r--r--tests/gexp.scm20
-rw-r--r--tests/monads.scm20
9 files changed, 114 insertions, 59 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index d629b51c8a..76c9e12992 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 4e16c53dcf..430f507520 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 039ca89889..5256d2195c 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 2a9e51511f..1e3dbf0944 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 ad51bc55b7..9ce6810172 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 0bd8ac9315..e1b056dc95 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 cf5848e580..bae8e7762b 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 e870f6cb1b..2376c70d1b 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 7f255f02bf..c05d13776a 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
generated by cgit v1.2.3 (git 2.50.1) at 2025-10-31 16:31:59 +0000