From dbde386794cb5f4773b94a20ef585ca0f881544a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 10 Apr 2022 23:43:08 +0200
Subject: [PATCH] tests: System tests really parameterize
 'current-guix-package'.

Until now, 'current-guix-package' was parameterized in the wrong
context.  Thus, 'current-guix' would end up building a variant of the
'guix' package instead of the package returned by
'channel-source->package', which is much less expensive to build.

* etc/system-tests.scm (mparameterize): New macro.
(tests-for-current-guix): Change the 'value' field of each <system-test>
record to parameterize 'current-guix-package' for good.
---
 etc/system-tests.scm | 39 ++++++++++++++++++++++++++++++---------
 1 file changed, 30 insertions(+), 9 deletions(-)

diff --git a/etc/system-tests.scm b/etc/system-tests.scm
index 1085deed24..de6f592dee 100644
--- a/etc/system-tests.scm
+++ b/etc/system-tests.scm
@@ -18,6 +18,8 @@
 
 (use-modules (gnu tests)
              (gnu packages package-management)
+             (guix monads)
+             (guix store)
              ((gnu ci) #:select (channel-source->package))
              ((guix git-download) #:select (git-predicate))
              ((guix utils) #:select (current-source-directory))
@@ -41,6 +43,21 @@ determined."
           (repository-close! repository))
         #f))))
 
+(define-syntax mparameterize
+  (syntax-rules ()
+    "This form implements dynamic scoping, similar to 'parameterize', but in a
+monadic context."
+    ((_ monad ((parameter value) rest ...) body ...)
+     (let ((old-value (parameter)))
+       (mbegin monad
+         ;; XXX: Non-local exits are not correctly handled.
+         (return (parameter value))
+         (mlet monad ((result (mparameterize monad (rest ...) body ...)))
+           (parameter old-value)
+           (return result)))))
+    ((_ monad () body ...)
+     (mbegin monad body ...))))
+
 (define (tests-for-current-guix source commit)
   "Return a list of tests for perform, using Guix built from SOURCE, a channel
 instance."
@@ -48,15 +65,19 @@ instance."
   ;; of tests to run in the usual way:
   ;;
   ;;   make check-system TESTS=installed-os
-  (parameterize ((current-guix-package
-                  (channel-source->package source #:commit commit)))
-    (match (getenv "TESTS")
-      (#f
-       (all-system-tests))
-      ((= string-tokenize (tests ...))
-       (filter (lambda (test)
-                 (member (system-test-name test) tests))
-               (all-system-tests))))))
+  (let ((guix (channel-source->package source #:commit commit)))
+    (map (lambda (test)
+           (system-test
+            (inherit test)
+            (value (mparameterize %store-monad ((current-guix-package guix))
+                     (system-test-value test)))))
+         (match (getenv "TESTS")
+           (#f
+            (all-system-tests))
+           ((= string-tokenize (tests ...))
+            (filter (lambda (test)
+                      (member (system-test-name test) tests))
+                    (all-system-tests)))))))
 
 (define (system-test->manifest-entry test)
   "Return a manifest entry for TEST, a system test."