amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

gexp: ‘with-parameters’ accepts plain store items in its body.

Browse source 
* guix/gexp.scm (compile-parameterized): Return ‘obj’ as-is when it’s
not a struct.
* tests/gexp.scm ("with-parameters + store item"): New test.

Change-Id: I5b5348b98bce923d07f6fa39b2f0948723011db8
This commit is contained in:
Ludovic Courtès 2025-01-28 14:51:00 +01:00
parent 72de3752f0
commit 3ad2d21671
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 24 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

20
guix/gexp.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014-2025 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@ -747,7 +747,12 @@ x86_64-linux when COREUTILS is lowered."
(target (if (memq %current-target-system parameters) (target (if (memq %current-target-system parameters)
(%current-target-system) (%current-target-system)
target))) target)))
(lower-object (thunk) system #:target 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) expander => (lambda (parameterized lowered output)
(match (parameterized-bindings parameterized) (match (parameterized-bindings parameterized)
@ -758,10 +763,13 @@ x86_64-linux when COREUTILS is lowered."
(with-fluids* fluids (with-fluids* fluids
(map (lambda (thunk) (thunk)) values) (map (lambda (thunk) (thunk)) values)
(lambda () (lambda ()
;; Delegate to the expander of the wrapped object. (match (thunk)
(let* ((base (thunk)) ((? struct? base)
(expand (lookup-expander base))) ;; Delegate to the expander of the wrapped object.
(expand base lowered output))))))))) (let ((expand (lookup-expander base)))
(expand base lowered output)))
(obj ;store item
obj)))))))))
;;; ;;;

11
tests/gexp.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014-2025 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021-2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021-2022 Maxime Devos <maximedevos@telenet.be>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -467,6 +467,15 @@
(string=? result (string=? result
(string-append (derivation->output-path drv) (string-append (derivation->output-path drv)
"/bin/touch")))))) "/bin/touch"))))))
(test-assert "with-parameters + store item"
(let* ((file (add-text-to-store %store "hello.txt" "Hello, world!"))
(obj (with-parameters ((%current-system "aarch64-linux"))
file))
(lowered (run-with-store %store
(lower-object obj))))
(string=? lowered file)))
(test-equal "let-system" (test-equal "let-system"
(list `(begin ,(%current-system) #t) '(system-binding) (list `(begin ,(%current-system) #t) '(system-binding)
'low '() '()) 'low '() '())