mirror of
https://https.git.savannah.gnu.org/git/guix.git/
synced 2025-07-10 08:30:39 +02:00
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>
This commit is contained in:
parent
749eb1a2dd
commit
30e51cb6b4
9 changed files with 114 additions and 59 deletions
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)))))
|
||||
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue