Browse Source

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.
gn-latest-20200428
Ludovic Courtès 2 years ago
parent
commit
cf2ac04f13
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 1
      .dir-locals.el
  2. 19
      doc/guix.texi
  3. 59
      guix/gexp.scm
  4. 38
      tests/gexp.scm

1
.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))

19
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

59
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.

38
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)

Loading…
Cancel
Save