From patchwork Tue Mar 4 20:33:08 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: David Elsing X-Patchwork-Id: 39692 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id DB8EA27BBEA; Tue, 4 Mar 2025 20:37:55 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-8.6 required=5.0 tests=BAYES_00,DKIMWL_WL_HIGH, DKIM_SIGNED,DKIM_VALID,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_MSPIKE_H2,RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL, RCVD_IN_VALIDITY_SAFE,SPF_HELO_PASS,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id C063A27BBE2 for ; Tue, 4 Mar 2025 20:37:54 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tpZ1G-0008Nq-TU; Tue, 04 Mar 2025 15:37:38 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tpZ0i-0008M8-DE for guix-patches@gnu.org; Tue, 04 Mar 2025 15:37:06 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tpZ0g-0007ao-Oi for guix-patches@gnu.org; Tue, 04 Mar 2025 15:37:03 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=ryBjbb5vflQbes5cCsiknEAfLknRhVquZ0vfNf8kynA=; b=PTpzOVMLp0qrwmQuAq/7EWVUpCps0l8Yjn2EUiriOc+L+4dbzp3+GItqzuQLWA43KKMo4zJlT2Pv1YcutVaJWQCIuJAC3p9RIn6qtk3GCXreErrEjqAn1ahywM9fyU97TAlvE/po/uzPq7PoDp4VFGoqZ5H9NPjRfbecMVpwoNCdZTDF7uOVRAe6J69CwQhq7+ai9trMmNqfjPgBqgsVh4patr7alwjGZbKnSmomdR9UYplq5BPp9wIqJdgCPtu7loJB9lDFZKJ49YRtv5rl45krvKJb/ZuQQuBV0ybwzOuJoA+4ApysFVMWPJT2E6XhB7OcnOOEtzN4ALNqZ3vRSA==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tpZ0g-00074V-7X for guix-patches@gnu.org; Tue, 04 Mar 2025 15:37:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#76485] [PATCH v2] gexp: =?utf-8?b?4oCYd2l0aC1wYXJhbWV0ZXJz4oCZ?= properly handles =?utf-8?b?4oCYJWdyYWZ0P+KAmS4=?= Resent-From: David Elsing Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 04 Mar 2025 20:37:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 76485 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 76485@debbugs.gnu.org Cc: David Elsing , ludo@gnu.org Received: via spool by 76485-submit@debbugs.gnu.org id=B76485.174112057727107 (code B ref 76485); Tue, 04 Mar 2025 20:37:02 +0000 Received: (at 76485) by debbugs.gnu.org; 4 Mar 2025 20:36:17 +0000 Received: from localhost ([127.0.0.1]:33145 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tpYzw-000735-Rx for submit@debbugs.gnu.org; Tue, 04 Mar 2025 15:36:17 -0500 Received: from mout02.posteo.de ([185.67.36.66]:54705) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tpYzt-00072p-OQ for 76485@debbugs.gnu.org; Tue, 04 Mar 2025 15:36:15 -0500 Received: from submission (posteo.de [185.67.36.169]) by mout02.posteo.de (Postfix) with ESMTPS id 16FAC240101 for <76485@debbugs.gnu.org>; Tue, 4 Mar 2025 21:36:05 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=posteo.net; s=2017; t=1741120567; bh=3PpVQ4LaOqg/XAPKeOFaWqIQiUG9f8bvWiohdLs4qJM=; h=From:To:Cc:Subject:Date:Message-ID:MIME-Version:Content-Type: Content-Transfer-Encoding:From; b=C+LpWarnf1X3TWSeLptq2thJ0FhlD7XWXCnWIHAMdbUPneYskmo1q1oFafYxkjYtu 8rc42b7YGVNt0did/eQ8Fm+uQmUXnFTjc2Glvd4j1p4s9Xy8luk0dGxMnDiato+mbB uYAOUIvgGQGozgjqbHclsKVpZYzZMnDRp8lkrcMupkIBCXG2YBlzEiFn2bSrsG2EcZ 07tDMhlmlHlavSaSqtTFbUzRMmNRnvBUZ1Azz+bkSmwySYm66Re9CDr9/k4IWInjw2 S4t12ddL6DO/3j67w1sAREsTkbJp+9Nl7ohQ7LFGAvC+6ZrTQi32QnxF1bci2QAxiy iYXwL9H2xukxg== Received: from customer (localhost [127.0.0.1]) by submission (posteo.de) with ESMTPSA id 4Z6nWn2NM9z6trs; Tue, 4 Mar 2025 21:36:05 +0100 (CET) From: David Elsing Date: Tue, 4 Mar 2025 20:33:08 +0000 Message-ID: <20250304203337.2628-1-david.elsing@posteo.net> In-Reply-To: <868qpky1uc.fsf@posteo.net> References: <868qpky1uc.fsf@posteo.net> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches Fixes . * .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 --- .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(-) 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 @@ (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 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 @@ (define-gexp-compiler (guix-instance-compiler (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))))) 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 @@ (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 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 @@ (define-gexp-compiler compile-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) diff --git a/guix/monads.scm b/guix/monads.scm index 0bd8ac9315..0df82bb465 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -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 + ;; . + (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 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 @@ (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. 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 @@ (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") 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 @@ (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