summaryrefslogtreecommitdiff
path: root/guix/gexp.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-03-06 11:25:43 +0100
committerLudovic Courtès <ludo@gnu.org>2020-03-12 18:32:15 +0100
commitcf2ac04f13d9266c7c8a2ebd2e85ef593231ac9d (patch)
tree409921980504c7138e4dac8769823fb50becc516 /guix/gexp.scm
parentbe78906592c761aa2a67e979074561e459efdcac (diff)
gexp: Add 'with-parameters'.
* guix/gexp.scm (<parameterized>): New record type. (with-parameters): New macro. (compile-parameterized): New gexp compiler. * tests/gexp.scm ("with-parameters for %current-system") ("with-parameters for %current-target-system") ("with-parameters + file-append"): New tests. * doc/guix.texi (G-Expressions): Document it.
Diffstat (limited to 'guix/gexp.scm')
-rw-r--r--guix/gexp.scm59
1 files changed, 59 insertions, 0 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index a657921741..133e0f5679 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -82,6 +82,9 @@
raw-derivation-file
raw-derivation-file?
+ with-parameters
+ parameterized?
+
load-path-expression
gexp-modules
@@ -523,6 +526,62 @@ SUFFIX."
(base (expand base lowered output)))
(string-append base (string-concatenate suffix)))))))
+;; Representation of SRFI-39 parameter settings in the dynamic scope of an
+;; object lowering.
+(define-record-type <parameterized>
+ (parameterized bindings thunk)
+ parameterized?
+ (bindings parameterized-bindings) ;list of parameter/value pairs
+ (thunk parameterized-thunk)) ;thunk
+
+(define-syntax-rule (with-parameters ((param value) ...) body ...)
+ "Bind each PARAM to the corresponding VALUE for the extent during which BODY
+is lowered. Consider this example:
+
+ (with-parameters ((%current-system \"x86_64-linux\"))
+ coreutils)
+
+It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
+x86_64-linux when COREUTILS is lowered."
+ (parameterized (list (list param (lambda () value)) ...)
+ (lambda ()
+ body ...)))
+
+(define-gexp-compiler compile-parameterized <parameterized>
+ compiler =>
+ (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)))
+ (lower-object (thunk) system #:target target))))))))
+
+ expander => (lambda (parameterized lowered output)
+ (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 ()
+ ;; Delegate to the expander of the wrapped object.
+ (let* ((base (thunk))
+ (expand (lookup-expander base)))
+ (expand base lowered output)))))))))
+
;;;
;;; Inputs & outputs.