[bug#29296] [PATCH 0/2] gexp: Add 'let-system'

[bug#29296] [PATCH 0/2] gexp: Add 'let-system'

[Ludovic Courtès]

Hello!

This patch adds the ‘let-system’ form to (guix gexp), as discussed with
Mathieu at <https://bugs.gnu.org/29281>.  It allows you to insert
system-dependent code inside a gexp, as in this 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)

(Using (%current-system) and (%current-target-system) does *not* achieve
this, in case you’re wondering, because at the time the gexp is defined
they carry their default value.)

Feedback welcome!

Ludo’.

Ludovic Courtès (2):
  gexp: Compilers can now return lowerable objects.
  gexp: Add 'let-system'.

 doc/guix.texi  |  26 ++++++++++++++
 guix/gexp.scm  | 105 ++++++++++++++++++++++++++++++++++++++++++++++++---------
 tests/gexp.scm |  50 +++++++++++++++++++++++++++
 3 files changed, 165 insertions(+), 16 deletions(-)

-- 
2.15.0

[bug#29296] [PATCH 1/2] gexp: Compilers can now return lowerable objects.

[Ludovic Courtès]

* 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 | 54 +++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 39 insertions(+), 15 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index b9525603e..c2d942c7f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -195,24 +195,50 @@ 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
-     (lower obj system target))))
+  (let loop ((obj obj))
+    (match (lookup-compiler obj)
+      (#f
+       (raise (condition (&gexp-input-error (input obj)))))
+      (lower
+       (mlet %store-monad ((lowered (lower obj system target)))
+         (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) ...))
 
@@ -795,12 +821,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> x)
          (return x))
         (x
-- 
2.15.0

[bug#29296] [PATCH 2/2] gexp: Add 'let-system'.

[Ludovic Courtès]

* 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 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)))
 
 \f
+;;;
+;;; 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)
+
+\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

[bug#29296] [PATCH 2/2] gexp: Add 'let-system'.

[Mathieu Othacehe]

Hi Ludo,

I must admit i don't have a perfect understanding of what is going on in
gexp.scm but your serie LGTM.

When diffing with the initial patch it seems that the entry in
.dir-locals.el is gone but it is a minor point.

About the integration of let-system in "system-disk-image", i'm not sure
how to proceed. let-system is meant to be used in a gexp but the
operating-system is not defined in a gexp.

Do you have any advice on how to turn os declaration into a gexp so that
i can use let-system to parameterize kernel field ?

Thanks,

Mathieu

[bug#29296] [PATCH 2/2] gexp: Add 'let-system'.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 1146 bytes --]

Hi Mathieu,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> I must admit i don't have a perfect understanding of what is going on in
> gexp.scm but your serie LGTM.
>
> When diffing with the initial patch it seems that the entry in
> .dir-locals.el is gone but it is a minor point.

Oops.

> About the integration of let-system in "system-disk-image", i'm not sure
> how to proceed. let-system is meant to be used in a gexp but the
> operating-system is not defined in a gexp.
>
> Do you have any advice on how to turn os declaration into a gexp so that
> i can use let-system to parameterize kernel field ?

The idea is that you can write:

  (kernel (let-system system
            (if (string-prefix? "arm-" system)
                linux-libre-arm
                linux-libre)))

and things will just work.

Now I found a couple of issues.  First one is addressed with the patch
below.  Second one is trickier: (file-append (let-system …) …), as is
used to compute the kernel file name, doesn’t work due to the way the
<file-append> expander works.

I’ll see what I can do.

Thanks,
Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 829 bytes --]

diff --git a/gnu/system.scm b/gnu/system.scm
index 9e05c4b21..a4804cf86 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -876,10 +876,12 @@ listed in OS.  The C library expects to find it under
 
 (define (kernel->boot-label kernel)
   "Return a label for the bootloader menu entry that boots KERNEL."
-  (string-append "GNU with "
-                 (string-titlecase (package-name kernel)) " "
-                 (package-version kernel)
-                 " (beta)"))
+  (if (package? kernel)
+      (string-append "GNU with "
+                     (string-titlecase (package-name kernel)) " "
+                     (package-version kernel)
+                     " (beta)")
+      "GNU GuixSD (beta)"))
 
 (define (store-file-system file-systems)
   "Return the file system object among FILE-SYSTEMS that contains the store."

[bug#29296] [PATCH 2/2] gexp: Add 'let-system'.

[Danny Milosavljevic]

[-- Attachment #1: Type: text/plain, Size: 1074 bytes --]

Hi Ludo,

maybe a little off-topic, but why do I have to use the following patch on
armhf-linux (*not* cross compiling) in order to stop it from pulling in
i686-cross-gcc?

Makes no sense to me at all...

diff --git a/gnu/packages/mes.scm b/gnu/packages/mes.scm
index 347aef0..524b8e8 100644
--- a/gnu/packages/mes.scm
+++ b/gnu/packages/mes.scm
@@ -120,8 +120,9 @@ extensive examples, including parsers for the Javascript and C99 languages.")
             ((string-prefix? "x86_64-linux" target-system)
              ;; Use cross-compiler rather than #:system "i686-linux" to get
              ;; MesCC 64 bit .go files installed ready for use with Guile.
-             `(("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
-               ("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))))
+             `( ;("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
+                ;("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))
+))
             (else
              '())))
        ("graphviz" ,graphviz)

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]

[bug#29296] [PATCH 2/2] gexp: Add 'let-system'.

[Marius Bakke]

[-- Attachment #1: Type: text/plain, Size: 1436 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

> Hi Ludo,
>
> maybe a little off-topic, but why do I have to use the following patch on
> armhf-linux (*not* cross compiling) in order to stop it from pulling in
> i686-cross-gcc?

Can you give a little more context?  Did this occur after the let-system
patch, or is this when using let-system?

Can you paste the derivation for mes@0.19 in the context this occurs?

Also, please file a new bug report.

> Makes no sense to me at all...

If only all bugs were obvious, our jobs would be so much easier!

> diff --git a/gnu/packages/mes.scm b/gnu/packages/mes.scm
> index 347aef0..524b8e8 100644
> --- a/gnu/packages/mes.scm
> +++ b/gnu/packages/mes.scm
> @@ -120,8 +120,9 @@ extensive examples, including parsers for the Javascript and C99 languages.")
>              ((string-prefix? "x86_64-linux" target-system)
>               ;; Use cross-compiler rather than #:system "i686-linux" to get
>               ;; MesCC 64 bit .go files installed ready for use with Guile.
> -             `(("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
> -               ("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))))
> +             `( ;("i686-linux-binutils" ,(cross-binutils "i686-unknown-linux-gnu"))
> +                ;("i686-linux-gcc" ,(cross-gcc "i686-unknown-linux-gnu"))
> +))
>              (else
>               '())))
>         ("graphviz" ,graphviz)

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 487 bytes --]