mirror/guix
mirror/guix
1
Fork 0
mirror of https://https.git.savannah.gnu.org/git/guix.git/ synced 2025-07-10 08:30:39 +02:00
Code Releases Activity

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

Browse source 
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>
This commit is contained in:
David Elsing 2025-03-04 20:33:08 +00:00 • committed by Ludovic Courtès
parent 749eb1a2dd
commit 30e51cb6b4
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
9 changed files with 114 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.dir-locals.el
View file

@ -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))

2
etc/manifests/system-tests.scm
View file

@ -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

8
etc/manifests/time-travel.scm
View file

@ -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)))))

8
gnu/tests.scm
View file

@ -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."

42
guix/gexp.scm
View file

@ -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)

68
guix/monads.scm
View file

@ -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

2
guix/store.scm
View file

@ -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.

20
tests/gexp.scm
View file

@ -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")

20
tests/monads.scm
View file

@ -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