From 644cb40cd83eff8a5bcdbd2d63887daa18228f41 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 14 Nov 2017 10:16:22 +0100
Subject: 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.
---
 tests/gexp.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 54 insertions(+)

(limited to 'tests')

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)
-- 
cgit 1.4.1