From 9ed86fe175c15c819d6d86681c8136ff6bc927c0 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 4 Apr 2015 21:59:25 +0200
Subject: tests: Add 'test-assertm' to (guix tests).

* guix/tests.scm (test-assertm): New macro.
* tests/gexp.scm (test-assertm): Remove.
* tests/profiles.scm (test-assertm): Remove.
* tests/challenge.scm (%store, test-assertm): Remove.
* tests/debug-link.scm (%store, test-assertm): Remove.
* tests/size.scm (%store, test-assertm): Remove.
---
 guix/tests.scm       | 25 +++++++++++++++++++++++++
 tests/challenge.scm  |  8 --------
 tests/debug-link.scm |  8 --------
 tests/gexp.scm       |  5 -----
 tests/profiles.scm   | 11 -----------
 tests/size.scm       |  8 --------
 6 files changed, 25 insertions(+), 40 deletions(-)

diff --git a/guix/tests.scm b/guix/tests.scm
index bcf9b990e5..66524ddc2f 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -27,6 +27,7 @@
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (web uri)
@@ -39,6 +40,8 @@
             shebang-too-long?
             mock
             %test-substitute-urls
+            test-assertm
+            test-equalm
             %substitute-directory
             with-derivation-narinfo
             with-derivation-substitute
@@ -161,6 +164,28 @@ given by REPLACEMENT."
       (lambda () body ...)
       (lambda () (module-set! m 'proc original)))))
 
+(define-syntax-rule (test-assertm name exp)
+  "Like 'test-assert', but EXP is a monadic value.  A new connection to the
+store is opened."
+  (test-assert name
+    (let ((store (open-connection-for-tests)))
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (run-with-store store exp
+                          #:guile-for-build (%guile-for-build)))
+        (lambda ()
+          (close-connection store))))))
+
+(define-syntax-rule (test-equalm name value exp)
+  "Like 'test-equal', but EXP is a monadic value.  A new connection to the
+store is opened."
+  (test-equal name
+    value
+    (with-store store
+      (run-with-store store exp
+                      #:guile-for-build (%guile-for-build)))))
+
 
 ;;;
 ;;; Narinfo files, as used by the substituter.
diff --git a/tests/challenge.scm b/tests/challenge.scm
index 4b13ec278e..c962800f3f 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -31,17 +31,9 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match))
 
-(define %store
-  (open-connection-for-tests))
-
 (define query-path-hash*
   (store-lift query-path-hash))
 
-(define-syntax-rule (test-assertm name exp)
-  (test-assert name
-    (run-with-store %store exp
-                    #:guile-for-build (%guile-for-build))))
-
 (define* (call-with-derivation-narinfo* drv thunk hash)
   (lambda (store)
     (with-derivation-narinfo drv (sha256 => hash)
diff --git a/tests/debug-link.scm b/tests/debug-link.scm
index 2dde3cb460..a1ae4f141c 100644
--- a/tests/debug-link.scm
+++ b/tests/debug-link.scm
@@ -43,14 +43,6 @@
 (define read-elf
   (compose parse-elf get-bytevector-all))
 
-(define %store
-  (open-connection-for-tests))
-
-(define-syntax-rule (test-assertm name exp)
-  (test-assert name
-    (run-with-store %store exp
-                    #:guile-for-build (%guile-for-build))))
-
 
 (test-begin "debug-link")
 
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 467370f8cb..ab60bdab68 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -62,11 +62,6 @@
                                      #:target target)
                   #:guile-for-build (%guile-for-build)))
 
-(define-syntax-rule (test-assertm name exp)
-  (test-assert name
-    (run-with-store %store exp
-                    #:guile-for-build (%guile-for-build))))
-
 (define %extension-package
   ;; Example of a package to use when testing 'with-extensions'.
   (dummy-package "extension"
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 9f366a04ef..1f9bbd099d 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -47,17 +47,6 @@
 ;; Globally disable grafts because they can trigger early builds.
 (%graft? #f)
 
-(define-syntax-rule (test-assertm name exp)
-  (test-assert name
-    (run-with-store %store exp
-                    #:guile-for-build (%guile-for-build))))
-
-(define-syntax-rule (test-equalm name value exp)
-  (test-equal name
-    value
-    (run-with-store %store exp
-                    #:guile-for-build (%guile-for-build))))
-
 ;; Example manifest entries.
 
 (define guile-1.8.8
diff --git a/tests/size.scm b/tests/size.scm
index 575b1abfdd..0aaa8fbc29 100644
--- a/tests/size.scm
+++ b/tests/size.scm
@@ -30,14 +30,6 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64))
 
-(define %store
-  (open-connection-for-tests))
-
-(define-syntax-rule (test-assertm name exp)
-  (test-assert name
-    (run-with-store %store exp
-                    #:guile-for-build (%guile-for-build))))
-
 
 (test-begin "size")
 
-- 
cgit v1.2.3