Merge branch 'master' into core-updates

4 files changed, 165 insertions, 4 deletions

diff --git a/tests/gexp.scm b/tests/gexp.scm
index bdea4b8563..694bd409bc 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -39,6 +39,7 @@
 
 ;; For white-box testing.
 (define gexp-inputs (@@ (guix gexp) gexp-inputs))
+(define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
 (define gexp->sexp  (@@ (guix gexp) gexp->sexp))
 
 (define guile-for-build
@@ -47,8 +48,9 @@
 ;; Make it the default.
 (%guile-for-build guile-for-build)
 
-(define (gexp->sexp* exp)
-  (run-with-store %store (gexp->sexp exp)
+(define* (gexp->sexp* exp #:optional target)
+  (run-with-store %store (gexp->sexp exp
+                                     #:target target)
                   #:guile-for-build guile-for-build))
 
 (define-syntax-rule (test-assertm name exp)
@@ -134,6 +136,29 @@
                (e3 `(display ,txt)))
            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 
+(test-assert "ungexp + ungexp-native"
+  (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
+                             (ungexp coreutils)
+                             (ungexp-native glibc)
+                             (ungexp binutils))))
+         (target "mips64el-linux")
+         (guile  (derivation->output-path
+                  (package-derivation %store %bootstrap-guile)))
+         (cu     (derivation->output-path
+                  (package-cross-derivation %store coreutils target)))
+         (libc   (derivation->output-path
+                  (package-derivation %store glibc)))
+         (bu     (derivation->output-path
+                  (package-cross-derivation %store binutils target))))
+    (and (lset= equal?
+                `((,%bootstrap-guile "out") (,glibc "out"))
+                (gexp-native-inputs exp))
+         (lset= equal?
+                `((,coreutils "out") (,binutils "out"))
+                (gexp-inputs exp))
+         (equal? `(list ,guile ,cu ,libc ,bu)
+                 (gexp->sexp* exp target)))))
+
 (test-assert "input list"
   (let ((exp   (gexp (display
                       '(ungexp (list %bootstrap-guile coreutils)))))
@@ -147,6 +172,28 @@
          (equal? `(display '(,guile ,cu))
                  (gexp->sexp* exp)))))
 
+(test-assert "input list + ungexp-native"
+  (let* ((target "mips64el-linux")
+         (exp   (gexp (display
+                       (cons '(ungexp-native (list %bootstrap-guile coreutils))
+                             '(ungexp (list glibc binutils))))))
+         (guile (derivation->output-path
+                 (package-derivation %store %bootstrap-guile)))
+         (cu    (derivation->output-path
+                 (package-derivation %store coreutils)))
+         (xlibc (derivation->output-path
+                 (package-cross-derivation %store glibc target)))
+         (xbu   (derivation->output-path
+                 (package-cross-derivation %store binutils target))))
+    (and (lset= equal?
+                `((,%bootstrap-guile "out") (,coreutils "out"))
+                (gexp-native-inputs exp))
+         (lset= equal?
+                `((,glibc "out") (,binutils "out"))
+                (gexp-inputs exp))
+         (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
+                 (gexp->sexp* exp target)))))
+
 (test-assert "input list splicing"
   (let* ((inputs  (list (list glibc "debug") %bootstrap-guile))
          (outputs (list (derivation->output-path
@@ -161,6 +208,16 @@
          (equal? (gexp->sexp* exp)
                  `(list ,@(cons 5 outputs))))))
 
+(test-assert "input list splicing + ungexp-native-splicing"
+  (let* ((inputs (list (list glibc "debug") %bootstrap-guile))
+         (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
+    (and (lset= equal?
+                `((,glibc "debug") (,%bootstrap-guile "out"))
+                (gexp-native-inputs exp))
+         (null? (gexp-inputs exp))
+         (equal? (gexp->sexp* exp)                ;native
+                 (gexp->sexp* exp "mips64el-linux")))))
+
 (test-assertm "gexp->file"
   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
                        (guile  (package-file %bootstrap-guile))
@@ -223,6 +280,55 @@
     (mlet %store-monad ((drv mdrv))
       (return (string=? system (derivation-system drv))))))
 
+(test-assertm "gexp->derivation, cross-compilation"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp    -> (gexp (list (ungexp coreutils)
+                                              (ungexp output))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (refs      ((store-lift references)
+                                   (derivation-file-name xdrv)))
+                       (xcu       (package->cross-derivation coreutils
+                                                             target))
+                       (cu        (package->derivation coreutils)))
+    (return (and (member (derivation-file-name xcu) refs)
+                 (not (member (derivation-file-name cu) refs))))))
+
+(test-assertm "gexp->derivation, ungexp-native"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp    -> (gexp (list (ungexp-native coreutils)
+                                              (ungexp output))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (drv       (gexp->derivation "foo" exp)))
+    (return (string=? (derivation-file-name drv)
+                      (derivation-file-name xdrv)))))
+
+(test-assertm "gexp->derivation, ungexp + ungexp-native"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp    -> (gexp (list (ungexp-native coreutils)
+                                              (ungexp glibc)
+                                              (ungexp output))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (refs      ((store-lift references)
+                                   (derivation-file-name xdrv)))
+                       (xglibc    (package->cross-derivation glibc target))
+                       (cu        (package->derivation coreutils)))
+    (return (and (member (derivation-file-name cu) refs)
+                 (member (derivation-file-name xglibc) refs)))))
+
+(test-assertm "gexp->derivation, ungexp-native + composed gexps"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp0   -> (gexp (list 1 2
+                                              (ungexp coreutils))))
+                       (exp    -> (gexp (list 0 (ungexp-native exp0))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (drv       (gexp->derivation "foo" exp)))
+    (return (string=? (derivation-file-name drv)
+                      (derivation-file-name xdrv)))))
+
 (define shebang
   (string-append "#!" (derivation->output-path guile-for-build)
                  "/bin/guile --no-auto-compile"))
@@ -268,8 +374,12 @@
 (test-equal "sugar"
   '(gexp (foo (ungexp bar) (ungexp baz "out")
               (ungexp (chbouib 42))
-              (ungexp-splicing (list x y z))))
-  '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)))
+              (ungexp-splicing (list x y z))
+              (ungexp-native foo) (ungexp-native foo "out")
+              (ungexp-native (chbouib 42))
+              (ungexp-native-splicing (list x y z))))
+  '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
+          #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
 
 (test-end "gexp")
 
diff --git a/tests/monads.scm b/tests/monads.scm
index ea3e4006ab..b814b0f7c5 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -24,6 +24,7 @@
                 #:select (package-derivation %current-system))
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
+  #:use-module ((gnu packages base) #:select (coreutils))
   #:use-module (ice-9 match)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
@@ -108,6 +109,30 @@
                       guile)))
     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 
+(test-assert "package-file, default system"
+  ;; The default system should be the one at '>>=' time, not the one at
+  ;; invocation time.  See <http://bugs.gnu.org/18002>.
+  (run-with-store %store
+    (mlet* %store-monad
+        ((system -> (%current-system))
+         (file   (parameterize ((%current-system "foobar64-linux"))
+                   (package-file coreutils "bin/ls")))
+         (cu     (package->derivation coreutils)))
+      (return (string=? file
+                        (string-append (derivation->output-path cu)
+                                       "/bin/ls"))))
+    #:guile-for-build (package-derivation %store %bootstrap-guile)))
+
+(test-assert "package-file + package->cross-derivation"
+  (run-with-store %store
+    (mlet* %store-monad ((file (package-file coreutils "bin/ls"
+                                             #:target "foo64-gnu"))
+                         (xcu  (package->cross-derivation coreutils
+                                                          "foo64-gnu")))
+      (let ((output (derivation->output-path xcu)))
+        (return (string=? file (string-append output "/bin/ls")))))
+    #:guile-for-build (package-derivation %store %bootstrap-guile)))
+
 (test-assert "interned-file"
   (run-with-store %store
     (mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d405f6453e..b2919d7315 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -40,6 +40,13 @@
 
 ;; Example manifest entries.
 
+(define guile-1.8.8
+  (manifest-entry
+    (name "guile")
+    (version "1.8.8")
+    (item "/gnu/store/...")
+    (output "out")))
+
 (define guile-2.0.9
   (manifest-entry
     (name "guile")
@@ -101,6 +108,20 @@
             (null? (manifest-entries m3))
             (null? (manifest-entries m4)))))))
 
+(test-assert "manifest-add"
+  (let* ((m0 (manifest '()))
+         (m1 (manifest-add m0 (list guile-1.8.8)))
+         (m2 (manifest-add m1 (list guile-2.0.9)))
+         (m3 (manifest-add m2 (list guile-2.0.9:debug)))
+         (m4 (manifest-add m3 (list guile-2.0.9:debug))))
+    (and (match (manifest-entries m1)
+           ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
+           (_ #f))
+         (match (manifest-entries m2)
+           ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
+           (_ #f))
+         (equal? m3 m4))))
+
 (test-assert "profile-derivation"
   (run-with-store %store
     (mlet* %store-monad
diff --git a/tests/ui.scm b/tests/ui.scm
index 4bf7a779c5..7cc02649e1 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -67,6 +67,11 @@ interface, and powerful string processing.")
                    10)
    #\newline))
 
+(test-equal "fill-paragraph, two spaces after period"
+  "First line.  Second line"
+  (fill-paragraph "First line.
+Second line" 24))
+
 (test-equal "package-specification->name+version+output"
   '(("guile" #f "out")
     ("guile" "2.0.9" "out")