33/104: gexp: Add 'let-system'.

[guix-commits]

nckx pushed a commit to branch core-updates
in repository guix.

commit 8d408d5ae4af4c90eee7ff241639aed00b03f887
Author: Ludovic Courtès <address@hidden>
AuthorDate: Tue Nov 14 10:16:22 2017 +0100

    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.
---
 .dir-locals.el |   1 +
 doc/guix.texi  |  26 ++++++++++++++
 guix/gexp.scm  | 110 +++++++++++++++++++++++++++++++++++++++++++--------------
 tests/gexp.scm |  54 ++++++++++++++++++++++++++++
 4 files changed, 165 insertions(+), 26 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index ce30560..fcde914 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 a36b969..d043852 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 da21057..7b33554 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 6a42d3e..e073a7b 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)