From 77f6fdb0158d76af9a6789bd0da45ac852ee2868 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sun, 9 May 2021 19:53:31 +0200
Subject: [PATCH] lint: Verify if #:tests? is respected in the 'check' phase.

There have been a few patches to the mailing list lately not
respecting this, and this linter detects 325 package definitions
that could be modified to support the --without-tests package
transformation.

* guix/lint.scm
  (check-optional-tests): New linter.
  (%local-checkers)[optional-tests]: Add it.
* tests/lint.scm
  (package-with-phase-changes): New procedure.
  ("optional-tests: no check phase")
  ("optional-tests: check phase respects #:tests?")
  ("optional-tests: check phase ignores #:tests?")
  ("optional-tests: do not crash when #:phases is invalid"): New tests.
---
 guix/lint.scm  | 40 ++++++++++++++++++++++++++++++++++++++++
 tests/lint.scm | 31 +++++++++++++++++++++++++++++++
 2 files changed, 71 insertions(+)

diff --git a/guix/lint.scm b/guix/lint.scm
index d1cbc9d300..f5db4664dc 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -87,6 +87,7 @@
             check-source
             check-source-file-name
             check-source-unstable-tarball
+            check-optional-tests
             check-mirror-url
             check-github-url
             check-license
@@ -963,6 +964,41 @@ descriptions maintained upstream."
                     (origin-uris origin))
         '())))
 
+(define (check-optional-tests package)
+  "Emit a warning if the test suite is run unconditionally."
+  (define (check-check-procedure expression)
+    (match expression
+      (`(,(or 'lambda 'lambda*) ,_ (invoke . ,_) . ,_)
+       (list (make-warning package
+                           ;; TRANSLATORS: check and #:tests? are a Scheme
+                           ;; symbol and keyword respectively and should not
+                           ;; be translated.
+                           (G_ "the 'check' phase should respect #:tests?")
+                           #:field 'arguments)))
+      ;; The 'check' phase seems ok, stop searching for a bug in this package
+      ;; definition.
+      (_ '())))
+  (define (check-phases-delta delta)
+    (match delta
+      (`(replace 'check ,expression)
+       (check-check-procedure expression))
+      (_ #f)))
+  (define (check-phases-deltas deltas)
+    (match deltas
+      (() '())
+      ((head . tail)
+       (or (check-phases-delta head)
+           (check-phases-deltas tail)))
+      (_ (list (make-warning package
+                             (G_ "incorrect call to modify-phases")
+                             #:field 'arguments)))))
+  (apply (lambda* (#:key phases #:allow-other-keys)
+           (match phases
+             (`(modify-phases ,_ . ,changes)
+              (check-phases-deltas changes))
+             (_ '())))
+         (package-arguments package)))
+
 (define (check-mirror-url package)
   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
   (define (check-mirror-uri uri)                  ;XXX: could be optimized
@@ -1529,6 +1565,10 @@ them for PACKAGE."
      (description "Make sure the 'license' field is a <license> \
 or a list thereof")
      (check       check-license))
+   (lint-checker
+     (name        'optional-tests)
+     (description "Make sure tests are only run when requested")
+     (check       check-optional-tests))
    (lint-checker
      (name        'mirror-url)
      (description "Suggest 'mirror://' URLs")
diff --git a/tests/lint.scm b/tests/lint.scm
index d6e877d0d7..c9cd6366ec 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -731,6 +731,37 @@
                                (sha256 %null-sha256))))))
     (check-source-unstable-tarball pkg)))
 
+(define (package-with-phase-changes changes)
+  (dummy-package "x"
+                 (arguments `(#:phases
+                              (modify-phases %standard-phases ,@changes)))))
+
+(test-equal "optional-tests: no check phase"
+  '()
+  (let ((pkg (package-with-phase-changes '())))
+    (check-optional-tests pkg)))
+(test-equal "optional-tests: check phase respects #:tests?"
+  '()
+  (let ((pkg (package-with-phase-changes
+              '((replace 'check
+                  (lambda (#:key tests? #:allow-other-keys?)
+                    (when tests?
+                      (invoke "./the-test-suite"))))))))
+    (check-optional-tests pkg)))
+(test-equal "optional-tests: check phase ignores #:tests?"
+  "the 'check' phase should respect #:tests?"
+  (let ((pkg (package-with-phase-changes
+              '((replace 'check
+                  (lambda _
+                    (invoke "./the-test-suite")))))))
+    (single-lint-warning-message
+     (check-optional-tests pkg))))
+(test-equal "optional-tests: do not crash when #:phases is invalid"
+  "incorrect call to modify-phases"
+  (let ((pkg (package-with-phase-changes 'this-is-not-a-list)))
+    (single-lint-warning-message
+     (check-optional-tests pkg))))
+
 (test-equal "source: 200"
   '()
   (with-http-server `((200 ,%long-string))
-- 
2.31.1