aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-11-14 10:16:22 +0100
committerLudovic Courtès <ludo@gnu.org>2020-05-16 00:34:41 +0200
commit644cb40cd83eff8a5bcdbd2d63887daa18228f41 (patch)
treee470f35ad20a8ad6805d2a8e7b03897bc10f6098
parentd03001a31a6d460b712825640dba11e3f1a53a14 (diff)
downloadguix-644cb40cd83eff8a5bcdbd2d63887daa18228f41.tar
guix-644cb40cd83eff8a5bcdbd2d63887daa18228f41.tar.gz
gexp: Add 'let-system'.
* guix/gexp.scm (<system-binding>): New record type. (let-system): New macro. (system-binding-compiler): New procedure. (default-expander): Add 'self-quoting?' case. (self-quoting?): New procedure. (lower-inputs): Add 'filterm'. Pass the result of 'mapm/accumulate-builds' through FILTERM. (gexp->sexp)[self-quoting?]: Remove. * tests/gexp.scm ("let-system", "let-system, target") ("let-system, ungexp-native, target") ("let-system, nested"): New tests. * doc/guix.texi (G-Expressions): Document it.
-rw-r--r--.dir-locals.el1
-rw-r--r--doc/guix.texi26
-rw-r--r--guix/gexp.scm110
-rw-r--r--tests/gexp.scm54
4 files changed, 165 insertions, 26 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index ce305602f2..fcde914e60 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -85,6 +85,7 @@
(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 'let-system '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 a36b9691fb..d043852ac3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8123,6 +8123,32 @@ 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} let-system @var{system} @var{body}@dots{}
+@deffnx {Scheme Syntax} let-system (@var{system} @var{target}) @var{body}@dots{}
+Bind @var{system} to the currently targeted system---e.g.,
+@code{"x86_64-linux"}---within @var{body}.
+
+In the second case, additionally bind @var{target} to the current
+cross-compilation target---a GNU triplet such as
+@code{"arm-linux-gnueabihf"}---or @code{#f} if we are not
+cross-compiling.
+
+@code{let-system} is useful in the occasional case where the object
+spliced into the gexp depends on the target system, as in this example:
+
+@example
+#~(system*
+ #+(let-system system
+ (cond ((string-prefix? "armhf-" system)
+ (file-append qemu "/bin/qemu-system-arm"))
+ ((string-prefix? "x86_64-" system)
+ (file-append qemu "/bin/qemu-system-x86_64"))
+ (else
+ (error "dunno!"))))
+ "-net" "user" #$image)
+@end example
+@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
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 5c614f3e12..78b8af6fbc 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -37,6 +37,7 @@
gexp?
with-imported-modules
with-extensions
+ let-system
gexp-input
gexp-input?
@@ -195,7 +196,9 @@ returns its output file name of OBJ's OUTPUT."
((? derivation? drv)
(derivation->output-path drv output))
((? string? file)
- file)))
+ file)
+ ((? self-quoting? obj)
+ obj)))
(define (register-compiler! compiler)
"Register COMPILER as a gexp compiler."
@@ -329,6 +332,52 @@ The expander specifies how an object is converted to its sexp representation."
;;;
+;;; System dependencies.
+;;;
+
+;; Binding form for the current system and cross-compilation target.
+(define-record-type <system-binding>
+ (system-binding proc)
+ system-binding?
+ (proc system-binding-proc))
+
+(define-syntax let-system
+ (syntax-rules ()
+ "Introduce a system binding in a gexp. The simplest form is:
+
+ (let-system system
+ (cond ((string=? system \"x86_64-linux\") ...)
+ (else ...)))
+
+which binds SYSTEM to the currently targeted system. The second form is
+similar, but it also shows the cross-compilation target:
+
+ (let-system (system target)
+ ...)
+
+Here TARGET is bound to the cross-compilation triplet or #f."
+ ((_ (system target) exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))
+ ((_ system exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))))
+
+(define-gexp-compiler system-binding-compiler <system-binding>
+ compiler => (lambda (binding system target)
+ (match binding
+ (($ <system-binding> proc)
+ (with-monad %store-monad
+ ;; PROC is expected to return a lowerable object.
+ ;; 'lower-object' takes care of residualizing it to a
+ ;; derivation or similar.
+ (return (proc system target))))))
+
+ ;; Delegate to the expander of the object returned by PROC.
+ expander => #f)
+
+
+;;;
;;; File declarations.
;;;
@@ -706,6 +755,15 @@ GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
list."
(gexp-attribute gexp gexp-self-extensions))
+(define (self-quoting? x)
+ (letrec-syntax ((one-of (syntax-rules ()
+ ((_) #f)
+ ((_ pred rest ...)
+ (or (pred x)
+ (one-of rest ...))))))
+ (one-of symbol? string? keyword? pair? null? array?
+ number? boolean? char?)))
+
(define* (lower-inputs inputs
#:key system target)
"Turn any object from INPUTS into a derivation input for SYSTEM or a store
@@ -714,23 +772,32 @@ When TARGET is true, use it as the cross-compilation target triplet."
(define (store-item? obj)
(and (string? obj) (store-path? obj)))
+ (define filterm
+ (lift1 (cut filter ->bool <>) %store-monad))
+
(with-monad %store-monad
- (mapm/accumulate-builds
- (match-lambda
- (((? struct? thing) sub-drv ...)
- (mlet %store-monad ((obj (lower-object
- thing system #:target target)))
- (return (match obj
- ((? derivation? drv)
- (let ((outputs (if (null? sub-drv)
- '("out")
- sub-drv)))
- (derivation-input drv outputs)))
- ((? store-item? item)
- item)))))
- (((? store-item? item))
- (return item)))
- inputs)))
+ (>>= (mapm/accumulate-builds
+ (match-lambda
+ (((? struct? thing) sub-drv ...)
+ (mlet %store-monad ((obj (lower-object
+ thing system #:target target)))
+ (return (match obj
+ ((? derivation? drv)
+ (let ((outputs (if (null? sub-drv)
+ '("out")
+ sub-drv)))
+ (derivation-input drv outputs)))
+ ((? store-item? item)
+ item)
+ ((? self-quoting?)
+ ;; Some inputs such as <system-binding> can lower to
+ ;; a self-quoting object that FILTERM will filter
+ ;; out.
+ #f)))))
+ (((? store-item? item))
+ (return item)))
+ inputs)
+ filterm)))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
@@ -1146,15 +1213,6 @@ references; otherwise, return only non-native references."
(target (%current-target-system)))
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)"
- (define (self-quoting? x)
- (letrec-syntax ((one-of (syntax-rules ()
- ((_) #f)
- ((_ pred rest ...)
- (or (pred x)
- (one-of rest ...))))))
- (one-of symbol? string? keyword? pair? null? array?
- number? boolean? char?)))
-
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 6a42d3eb57..e073a7b816 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -321,6 +321,60 @@
(string=? result
(string-append (derivation->output-path drv)
"/bin/touch"))))))
+(test-equal "let-system"
+ (list `(begin ,(%current-system) #t) '(system-binding) '()
+ 'low '() '())
+ (let* ((exp #~(begin
+ #$(let-system system system)
+ #t))
+ (low (run-with-store %store (lower-gexp exp))))
+ (list (lowered-gexp-sexp low)
+ (match (gexp-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x))
+ (gexp-native-inputs exp)
+ 'low
+ (lowered-gexp-inputs low)
+ (lowered-gexp-sources low))))
+
+(test-equal "let-system, target"
+ (list `(list ,(%current-system) #f)
+ `(list ,(%current-system) "aarch64-linux-gnu"))
+ (let ((exp #~(list #$@(let-system (system target)
+ (list system target)))))
+ (list (gexp->sexp* exp)
+ (gexp->sexp* exp "aarch64-linux-gnu"))))
+
+(test-equal "let-system, ungexp-native, target"
+ `(here it is: ,(%current-system) #f)
+ (let ((exp #~(here it is: #+@(let-system (system target)
+ (list system target)))))
+ (gexp->sexp* exp "aarch64-linux-gnu")))
+
+(test-equal "let-system, nested"
+ (list `(system* ,(string-append "qemu-system-" (%current-system))
+ "-m" "256")
+ '()
+ '(system-binding))
+ (let ((exp #~(system*
+ #+(let-system (system target)
+ (file-append (@@ (gnu packages virtualization)
+ qemu)
+ "/bin/qemu-system-"
+ system))
+ "-m" "256")))
+ (list (match (gexp->sexp* exp)
+ (('system* command rest ...)
+ `(system* ,(and (string-prefix? (%store-prefix) command)
+ (basename command))
+ ,@rest))
+ (x x))
+ (gexp-inputs exp)
+ (match (gexp-native-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x)))))
(test-assert "ungexp + ungexp-native"
(let* ((exp (gexp (list (ungexp-native %bootstrap-guile)