Merge branch 'master' into core-updates

4 files changed, 96 insertions, 52 deletions

diff --git a/tests/gexp.scm b/tests/gexp.scm
index ea4df48403..d80f14344d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -421,6 +421,30 @@
       (return (and (zero? (close-pipe pipe))
                    (= (expt n 2) (string->number str)))))))
 
+(test-assert "text-file*"
+  (let ((references (store-lift references)))
+    (run-with-store %store
+      (mlet* %store-monad
+          ((drv  (package->derivation %bootstrap-guile))
+           (guile -> (derivation->output-path drv))
+           (file (text-file "bar" "This is bar."))
+           (text (text-file* "foo"
+                             %bootstrap-guile "/bin/guile "
+                             `(,%bootstrap-guile "out") "/bin/guile "
+                             drv "/bin/guile "
+                             file))
+           (done (built-derivations (list text)))
+           (out -> (derivation->output-path text))
+           (refs (references out)))
+        ;; Make sure we get the right references and the right content.
+        (return (and (lset= string=? refs (list guile file))
+                     (equal? (call-with-input-file out get-string-all)
+                             (string-append guile "/bin/guile "
+                                            guile "/bin/guile "
+                                            guile "/bin/guile "
+                                            file)))))
+      #:guile-for-build (package-derivation %store %bootstrap-guile))))
+
 (test-assert "printer"
   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
  \"/bin/uname\"\\) [[:xdigit:]]+>$"
diff --git a/tests/lint.scm b/tests/lint.scm
index c6931329d6..27be5598de 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -75,9 +75,20 @@
     (quit #t)                                     ;exit the server thread
     (values)))
 
+;; Mutex and condition variable to synchronize with the HTTP server.
+(define %http-server-lock (make-mutex))
+(define %http-server-ready (make-condition-variable))
+
+(define (http-open . args)
+  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+  (with-mutex %http-server-lock
+    (let ((result (apply (@@ (web server http) http-open) args)))
+      (signal-condition-variable %http-server-ready)
+      result)))
+
 (define-server-impl stub-http-server
   ;; Stripped-down version of Guile's built-in HTTP server.
-  (@@ (web server http) http-open)
+  http-open
   (@@ (web server http) http-read)
   http-write
   (@@ (web server http) http-close))
@@ -97,9 +108,11 @@ requests."
                     `(#:socket ,%http-server-socket)))
       (const #t)))
 
-  (let* ((server (make-thread server-body)))
-    ;; Normally SERVER exits automatically once it has received a request.
-    (thunk)))
+  (with-mutex %http-server-lock
+    (let ((server (make-thread server-body)))
+      (wait-condition-variable %http-server-ready %http-server-lock)
+      ;; Normally SERVER exits automatically once it has received a request.
+      (thunk))))
 
 (define-syntax-rule (with-http-server code body ...)
   (call-with-http-server code (lambda () body ...)))
diff --git a/tests/monads.scm b/tests/monads.scm
index 6e3dd00f72..9c3cdd20a7 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -156,51 +156,6 @@
                       (call-with-input-file b get-string-all))))
     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 
-(define derivation-expression
-  (@@ (guix monads) derivation-expression))
-
-(test-assert "mlet* + derivation-expression"
-  (run-with-store %store
-    (mlet* %store-monad ((guile  (package-file %bootstrap-guile "bin/guile"))
-                         (gdrv   (package->derivation %bootstrap-guile))
-                         (exp -> `(let ((out (assoc-ref %outputs "out")))
-                                    (mkdir out)
-                                    (symlink ,guile
-                                             (string-append out "/guile-rocks"))))
-                         (drv    (derivation-expression "rocks" exp
-                                                        #:inputs
-                                                        `(("g" ,gdrv))))
-                         (out -> (derivation->output-path drv))
-                         (built? (built-derivations (list drv))))
-      (return (and built?
-                   (equal? guile
-                           (readlink (string-append out "/guile-rocks"))))))
-    #:guile-for-build (package-derivation %store %bootstrap-guile)))
-
-(test-assert "text-file*"
-  (let ((references (store-lift references)))
-    (run-with-store %store
-      (mlet* %store-monad
-          ((drv  (package->derivation %bootstrap-guile))
-           (guile -> (derivation->output-path drv))
-           (file (text-file "bar" "This is bar."))
-           (text (text-file* "foo"
-                             %bootstrap-guile "/bin/guile "
-                             `(,%bootstrap-guile "out") "/bin/guile "
-                             drv "/bin/guile "
-                             file))
-           (done (built-derivations (list text)))
-           (out -> (derivation->output-path text))
-           (refs (references out)))
-        ;; Make sure we get the right references and the right content.
-        (return (and (lset= string=? refs (list guile file))
-                     (equal? (call-with-input-file out get-string-all)
-                             (string-append guile "/bin/guile "
-                                            guile "/bin/guile "
-                                            guile "/bin/guile "
-                                            file)))))
-      #:guile-for-build (package-derivation %store %bootstrap-guile))))
-
 (test-assert "mapm"
   (every (lambda (monad run)
            (with-monad monad
diff --git a/tests/sets.scm b/tests/sets.scm
new file mode 100644
index 0000000000..0a89591765
--- /dev/null
+++ b/tests/sets.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-sets)
+  #:use-module (guix sets)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64))
+
+
+(test-begin "sets")
+
+(test-assert "set-contains?"
+  (let* ((lst (iota 123))
+         (set (list->set lst)))
+    (and (every (cut set-contains? set <>)
+                lst)
+         (not (set-contains? set -1)))))
+
+(test-assert "set->list"
+  (let* ((lst (iota 123))
+         (set (list->set lst)))
+    (lset= = lst (set->list set))))
+
+(test-assert "set-union"
+  (let* ((a  (list 'a))
+         (b  (list 'b))
+         (s1 (setq a))
+         (s2 (setq b))
+         (s3 (set-union s1 s2)))
+    (and (set-contains? s3 a)
+         (set-contains? s3 b))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))