summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMaxime Devos <maximedevos@telenet.be>2021-06-28 20:44:16 +0200
committerMathieu Othacehe <othacehe@gnu.org>2021-06-30 13:53:00 +0200
commit5532371a3a25adaa023a00ae1004c2f422f3abc8 (patch)
tree36b9ce9fcf4dbdebbf7cbbb418a97089c6ef18e8 /guix
parentd9e0ae07db5cb9f949c11f4ee77146a070c2618c (diff)
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 630 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 hase respects #:tests?") ("optional-tests: check phase ignores #:tests?") ("optional-tests: do not crash when #:phases is invalid") ("optional-tests: allow G-exps (no warning)") ("optional-tests: allow G-exps (warning)") ("optional-tests: complicated 'check' phase") ("optional-tests: 'check' phase is not first phase"): New tests. Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
Diffstat (limited to 'guix')
-rw-r--r--guix/lint.scm60
1 files changed, 59 insertions, 1 deletions
diff --git a/guix/lint.scm b/guix/lint.scm
index 70ed677a54..1f48bcc454 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -40,7 +40,8 @@
#:use-module (guix packages)
#:use-module (guix i18n)
#:use-module ((guix gexp)
- #:select (local-file? local-file-absolute-file-name))
+ #:select (gexp? local-file? local-file-absolute-file-name
+ gexp->approximate-sexp))
#:use-module (guix licenses)
#:use-module (guix records)
#:use-module (guix grafts)
@@ -89,6 +90,7 @@
check-source
check-source-file-name
check-source-unstable-tarball
+ check-optional-tests
check-mirror-url
check-github-url
check-license
@@ -1098,6 +1100,58 @@ descriptions maintained upstream."
(define exception-with-kind-and-args?
(exception-predicate &exception-with-kind-and-args))
+(define (check-optional-tests package)
+ "Emit a warning if the test suite is run unconditionally."
+ (define (sexp-contains-atom? sexp atom)
+ "Test if SEXP contains ATOM."
+ (if (pair? sexp)
+ (or (sexp-contains-atom? (car sexp) atom)
+ (sexp-contains-atom? (cdr sexp) atom))
+ (eq? sexp atom)))
+ (define (sexp-uses-tests?? sexp)
+ "Test if SEXP contains the symbol 'tests?'."
+ (sexp-contains-atom? sexp 'tests?))
+ (define (check-check-procedure expression)
+ (match expression
+ (`(,(or 'let 'let*) . ,_)
+ (check-check-procedure (car (last-pair expression))))
+ (`(,(or 'lambda 'lambda*) ,_ . ,code)
+ (if (sexp-uses-tests?? code)
+ '()
+ (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))))
+ (_ '())))
+ (define (check-phases-delta delta)
+ (match delta
+ (`(replace 'check ,expression)
+ (check-check-procedure expression))
+ (_ '())))
+ (define (check-phases-deltas deltas)
+ (match deltas
+ (() '())
+ ((head . tail)
+ (append (check-phases-delta head)
+ (check-phases-deltas tail)))
+ (_ (list (make-warning package
+ ;; TRANSLATORS: modify-phases is a Scheme
+ ;; syntax and must not be translated.
+ (G_ "incorrect call to ‘modify-phases’")
+ #:field 'arguments)))))
+ (apply (lambda* (#:key phases #:allow-other-keys)
+ (define phases/sexp
+ (if (gexp? phases)
+ (gexp->approximate-sexp phases)
+ phases))
+ (match phases/sexp
+ (`(modify-phases ,_ . ,changes)
+ (check-phases-deltas changes))
+ (_ '())))
+ (package-arguments package)))
+
(define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation."
(define (try store system)
@@ -1599,6 +1653,10 @@ them for PACKAGE."
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")
(check check-mirror-url))