Hello,
> We could maybe do something like that:
>
> (define (operating-system-hardware-specific-services)
> #~(let-system (system target)
> (cond
> ((target-arm? system target)
> '())
> ((target-intel? system target)
> (list uvesafb-shepherd-service)))))
>
> (define (operating-system-kernel-specific-services)
> #~(let-system (system target)
> (cond
> ((target-linux? system target)
> linux-specific-services)
> ((target-hurd? system target)
> hurd-specific-services))))
>
> This way, uvesafb-shepherd-service would be built and installed only
> when producing a system targeting an Intel CPU. We could also extend
> this mechanism to have kernel specific services.
>
> That would mean, we need to dig out Ludo patch introducing
> let-system[1], but I think it was almost ready.
Here's a rebased version of Ludo's patch. I'm not sure about the merge
resolution in "lower-object", but otherwise it works fine!
Ludo, would it be of to push it?
Thanks,
Mathieu
>From dde0a1ca499a4ef0592d10158a00add16386bebb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org>
Date: Wed, 13 May 2020 14:34:17 +0200
Subject: [PATCH 1/2] gexp: Compilers can now return lowerable objects.
* guix/gexp.scm (lower-object): Iterate if LOWERED is a struct.
(lower+expand-object): New procedure.
(gexp->sexp): Use it.
(define-gexp-compiler): Adjust docstring.
---
guix/gexp.scm | 71 ++++++++++++++++++++++++++++++++++-----------------
1 file changed, 48 insertions(+), 23 deletions(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 2a4b36519c..a9a4b89ab4 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -226,32 +226,59 @@ procedure to expand it; otherwise return #f."
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
OBJ must be an object that has an associated gexp compiler, such as a
<package>."
- (match (lookup-compiler obj)
- (#f
- (raise (condition (&gexp-input-error (input obj)))))
- (lower
- ;; Cache in STORE the result of lowering OBJ.
- (mlet %store-monad ((target (if (eq? target 'current)
- (current-target-system)
- (return target)))
- (graft? (grafting?)))
- (mcached (let ((lower (lookup-compiler obj)))
- (lower obj system target))
- obj
- system target graft?)))))
+ (let loop ((obj obj))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ ;; Cache in STORE the result of lowering OBJ.
+ (mlet* %store-monad
+ ((target (if (eq? target 'current)
+ (current-target-system)
+ (return target)))
+ (graft? (grafting?))
+ (lowered (mcached (let ((lower (lookup-compiler obj)))
+ (lower obj system target))
+ obj
+ system target graft?)))
+ (if (and (struct? lowered) (not (eq? lowered obj)))
+ (loop lowered)
+ (return lowered)))))))
+
+(define* (lower+expand-object obj
+ #:optional (system (%current-system))
+ #:key target (output "out"))
+ "Return as a value in %STORE-MONAD the output of object OBJ expands to for
+SYSTEM and TARGET. Object such as <package>, <file-append>, or <plain-file>
+expand to file names, but it's possible to expand to a plain data type."
+ (let loop ((obj obj)
+ (expand (and (struct? obj) (lookup-expander obj))))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ (mlet %store-monad ((lowered (lower obj system target)))
+ ;; LOWER might return something that needs to be further lowered.
+ (if (struct? lowered)
+ ;; If we lack an expander, delegate to that of LOWERED.
+ (if (not expand)
+ (loop lowered (lookup-expander lowered))
+ (return (expand obj lowered output)))
+ (return lowered))))))) ;lists, vectors, etc.
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
"Define NAME as a compiler for objects matching PREDICATE encountered in
gexps.
-In the simplest form of the macro, BODY must return a derivation for PARAM, an
-object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
-#f except when cross-compiling.)
+In the simplest form of the macro, BODY must return (1) a derivation for
+a record of the specified type, for SYSTEM and TARGET (the latter of which is
+#f except when cross-compiling), (2) another record that can itself be
+compiled down to a derivation, or (3) an object of a primitive data type.
The more elaborate form allows you to specify an expander:
- (define-gexp-compiler something something?
+ (define-gexp-compiler something-compiler <something>
compiler => (lambda (param system target) ...)
expander => (lambda (param drv output) ...))
@@ -1148,12 +1175,10 @@ and in the current monad setting (system type, etc.)"
(or n? native?)))
refs))
(($ <gexp-input> (? struct? thing) output n?)
- (let ((target (if (or n? native?) #f target))
- (expand (lookup-expander thing)))
- (mlet %store-monad ((obj (lower-object thing system
- #:target target)))
- ;; OBJ must be either a derivation or a store file name.
- (return (expand thing obj output)))))
+ (let ((target (if (or n? native?) #f target)))
+ (lower+expand-object thing system
+ #:target target
+ #:output output)))
(($ <gexp-input> (? self-quoting? x))
(return x))
(($ <gexp-input> x)
--
2.26.2
>From 8fe7504a0935de7f0c8cba1236f3114d4e368093 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <l...@gnu.org>
Date: Wed, 13 May 2020 14:35:20 +0200
Subject: [PATCH 2/2] gexp: Add 'let-system'.
* 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(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index d6fbd85fde..0281a4be45 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7811,6 +7811,32 @@ are also added to the load path of the gexp returned by
Return @code{#t} if @var{obj} is a G-expression.
@end deffn
+@deffn {Scheme Syntax} let-system @var{system}
+@deffnx {Scheme Syntax} let-system (@var{system} @var{target})
+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 a9a4b89ab4..a70b723e57 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -112,6 +112,7 @@
gexp-compiler?
file-like?
lower-object
+ let-system
lower-inputs
@@ -195,7 +196,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."
@@ -324,6 +327,52 @@ The expander specifies how an object is converted to its sexp representation."
(derivation-file-name lowered)
lowered)))
+
+;;;
+;;; 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 6a42d3eb57..c1d65b2c4e 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -322,6 +322,56 @@
(string-append (derivation->output-path drv)
"/bin/touch"))))))
+(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.26.2
