From d326767e6417cbaad2856e6641e98dd80311b8c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 11 Jan 2015 23:43:30 +0100 Subject: Add (guix sets). * guix/sets.scm, tests/sets.scm: New files.sets * Makefile.am (MODULES, SCM_TESTS): Add them. --- tests/sets.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 tests/sets.scm (limited to 'tests') 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 +;;; +;;; 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 . + +(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)) -- cgit v1.2.3 From 462a3fa36cddeb683df765b2982f76712f6c40f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 12 Jan 2015 23:26:52 +0100 Subject: monads: Rewrite 'text-file*' using gexps. * guix/monads.scm (text-file*): Move to... * guix/gexp.scm (text-file*): ... here. Rewrite using gexps. * tests/monads.scm ("text-file*"): Move to... * tests/gexp.scm ("text-file*"): ... here. --- tests/gexp.scm | 26 +++++++++++++++++++++++++- tests/monads.scm | 26 +------------------------- 2 files changed, 26 insertions(+), 26 deletions(-) (limited to 'tests') 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 +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; 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 "^#$" diff --git a/tests/monads.scm b/tests/monads.scm index 6e3dd00f72..bac9feb97a 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 +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -177,30 +177,6 @@ (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 -- cgit v1.2.3 From abebac46017f626f25b5c84bdcc1013c3d17632f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 12 Jan 2015 23:32:34 +0100 Subject: monads: Remove 'derivation-expression'. * guix/monads.scm (lower-inputs, derivation-expression): Remove. * tests/monads.scm (derivation-expression, "mlet* + derivation-expression"): Remove. --- tests/monads.scm | 21 --------------------- 1 file changed, 21 deletions(-) (limited to 'tests') diff --git a/tests/monads.scm b/tests/monads.scm index bac9feb97a..9c3cdd20a7 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -156,27 +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 "mapm" (every (lambda (monad run) (with-monad monad -- cgit v1.2.3 From 4655005e2441c7001a89293242719fe35b894e40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 13 Jan 2015 11:08:23 +0100 Subject: tests: Properly synchronize threads in the 'home-page' lint tests. * tests/lint.scm (%http-server-lock, %http-server-ready): New variables. (http-open): New procedure. (stub-http-server): Use it. (call-with-http-server): Wrap body in 'with-mutex'. Call 'wait-condition-variable' after 'make-thread'. --- tests/lint.scm | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) (limited to 'tests') 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 ;;; Copyright © 2014 Eric Bavier -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; 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 ...))) -- cgit v1.2.3