diff options
author | Maxime Devos <maximedevos@telenet.be> | 2021-06-28 20:44:16 +0200 |
---|---|---|
committer | Mathieu Othacehe <othacehe@gnu.org> | 2021-06-30 13:53:00 +0200 |
commit | 5532371a3a25adaa023a00ae1004c2f422f3abc8 (patch) | |
tree | 36b9ce9fcf4dbdebbf7cbbb418a97089c6ef18e8 /guix | |
parent | d9e0ae07db5cb9f949c11f4ee77146a070c2618c (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.scm | 60 |
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)) |