[bug#76485,v2] gexp: ‘with-parameters’ properly handles ‘%graft?’.
Commit Message
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>
---
.dir-locals.el | 3 +-
etc/manifests/system-tests.scm | 2 +-
etc/manifests/time-travel.scm | 8 +++---
gnu/tests.scm | 8 +++---
guix/gexp.scm | 42 ++++++++++++++-------------
guix/monads.scm | 52 +++++++++++++++++++++++-----------
guix/store.scm | 2 ++
tests/gexp.scm | 20 +++++++++++++
tests/monads.scm | 20 ++++++-------
9 files changed, 99 insertions(+), 58 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 @@ (define (tests-for-current-guix source commit)
(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 @@ (define-gexp-compiler (guix-instance-compiler (instance <guix-instance>)
;; 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 @@ (define-module (gnu tests)
#: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 @@ (define (write-system-test test port)
(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 @@ (define-gexp-compiler compile-parameterized <parameterized>
(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)
@@ -40,7 +40,6 @@ (define-module (guix monads)
mbegin
mwhen
munless
- mparameterize
lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
listm
foldm
@@ -58,7 +57,8 @@ (define-module (guix monads)
set-current-state
state-push
state-pop
- run-with-state))
+ run-with-state
+ state-parameterize))
;;; Commentary:
;;;
@@ -399,21 +399,6 @@ (define-syntax munless
(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 +585,37 @@ (define (state-push 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 ...))))))))
+
;;; monads.scm end here
@@ -178,6 +178,7 @@ (define-module (guix store)
store-lift
store-lower
run-with-store
+ store-parameterize
%guile-for-build
current-system
set-current-system
@@ -1919,6 +1920,7 @@ (define-syntax new (identifier-syntax old)))
(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 @@ (define (match-input thing)
(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 @@ (define (g x)
%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