summaryrefslogtreecommitdiff
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
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.
-rw-r--r--.dir-locals.el1
-rw-r--r--doc/guix.texi19
-rw-r--r--guix/gexp.scm59
-rw-r--r--tests/gexp.scm38
4 files changed, 117 insertions, 0 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 5ce3fbc9a5..1976f7e60d 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -83,6 +83,7 @@
(eval . (put 'wrap-program 'scheme-indent-function 1))
(eval . (put 'with-imported-modules 'scheme-indent-function 1))
(eval . (put 'with-extensions 'scheme-indent-function 1))
+ (eval . (put 'with-parameters 'scheme-indent-function 1))
(eval . (put 'with-database 'scheme-indent-function 2))
(eval . (put 'call-with-transaction 'scheme-indent-function 2))
diff --git a/doc/guix.texi b/doc/guix.texi
index dd32b65fe0..4f8f7cfb2a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8022,6 +8022,25 @@ the second case, the resulting script contains a @code{(string-append
@dots{})} expression to construct the file name @emph{at run time}.
@end deffn
+@deffn {Scheme Syntax} with-parameters ((@var{parameter} @var{value}) @dots{}) @var{exp}
+This macro is similar to the @code{parameterize} form for
+dynamically-bound @dfn{parameters} (@pxref{Parameters,,, guile, GNU
+Guile Reference Manual}). The key difference is that it takes effect
+when the file-like object returned by @var{exp} is lowered to a
+derivation or store item.
+
+A typical use of @code{with-parameters} is to force the system in effect
+for a given object:
+
+@lisp
+(with-parameters ((%current-system "i686-linux"))
+ coreutils)
+@end lisp
+
+The example above returns an object that corresponds to the i686 build
+of Coreutils, regardless of the current value of @code{%current-system}.
+@end deffn
+
Of course, in addition to gexps embedded in ``host'' code, there are
also modules containing build tools. To make it clear that they are
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.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 9e38816c3d..6a42d3eb57 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -284,6 +284,44 @@
(((thing "out"))
(eq? thing file))))))
+(test-assertm "with-parameters for %current-system"
+ (mlet* %store-monad ((system -> (match (%current-system)
+ ("aarch64-linux" "x86_64-linux")
+ (_ "aarch64-linux")))
+ (drv (package->derivation coreutils system))
+ (obj -> (with-parameters ((%current-system system))
+ coreutils))
+ (result (lower-object obj)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name result)))))
+
+(test-assertm "with-parameters for %current-target-system"
+ (mlet* %store-monad ((target -> "riscv64-linux-gnu")
+ (drv (package->cross-derivation coreutils target))
+ (obj -> (with-parameters
+ ((%current-target-system target))
+ coreutils))
+ (result (lower-object obj)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name result)))))
+
+(test-assert "with-parameters + file-append"
+ (let* ((system (match (%current-system)
+ ("aarch64-linux" "x86_64-linux")
+ (_ "aarch64-linux")))
+ (drv (package-derivation %store coreutils system))
+ (param (make-parameter 7))
+ (exp #~(here we go #$(with-parameters ((%current-system system)
+ (param 42))
+ (if (= (param) 42)
+ (file-append coreutils "/bin/touch")
+ %bootstrap-guile)))))
+ (match (gexp->sexp* exp)
+ (('here 'we 'go (? string? result))
+ (string=? result
+ (string-append (derivation->output-path drv)
+ "/bin/touch"))))))
+
(test-assert "ungexp + ungexp-native"
(let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
(ungexp coreutils)