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(+)
@@ -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")
@@ -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