* guix/gexp.scm (<system-binding>): New record type.
(let-system): New macro.
(system-binding-compiler): New procedure.
(default-expander): Add catch-all case.
* 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.
---
doc/guix.texi | 26 ++++++++++++++++++++++++++
guix/gexp.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++-
tests/gexp.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 126 insertions(+), 1 deletion(-)
Toggle diff (176 lines)
diff --git a/doc/guix.texi b/doc/guix.texi
index 098ff5e54..0e795ada6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4799,6 +4799,32 @@ procedures called from @var{body}@dots{}.
Return @code{#t} if @var{obj} is a G-expression.
@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
+
G-expressions are meant to be written to disk, either as code building
some derivation, or as plain files in the store. The monadic procedures
below allow you to do that (@pxref{The Store Monad}, for more
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c2d942c7f..c65c6e5f3 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -32,6 +32,7 @@
#:export (gexp
gexp?
with-imported-modules
+ let-system
gexp-input
gexp-input?
@@ -169,7 +170,9 @@ returns its output file name of OBJ's OUTPUT."
((? derivation? drv)
(derivation->output-path drv output))
((? string? file)
- file)))
+ file)
+ (obj ;lists, vectors, etc.
+ obj)))
(define (register-compiler! compiler)
"Register COMPILER as a gexp compiler."
@@ -262,6 +265,52 @@ The expander specifies how an object is converted to its sexp representation."
(return drv)))
+;;;
+;;; 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.
;;;
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 5873abdd4..f98d1e70e 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -258,6 +258,56 @@
(((thing "out"))
(eq? thing file))))))
+(test-equal "let-system"
+ (list `(begin ,(%current-system) #t) '(system-binding) '())
+ (let ((exp #~(begin
+ #$(let-system system system)
+ #t)))
+ (list (gexp->sexp* exp)
+ (match (gexp-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x))
+ (gexp-native-inputs exp))))
+
+(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)
(ungexp coreutils)
--
2.15.0
