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>
This commit is contained in:
Maxime Devos
Mathieu Othacehe
parent
d9e0ae07db
commit
5532371a3a
@ -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)
|
||||
@ -1598,6 +1652,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")
|
||||
|
||||
@ -9,6 +9,7 @@
|
||||
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
|
||||
;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
|
||||
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
||||
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@ -38,7 +39,7 @@
|
||||
#:use-module (guix lint)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix swh)
|
||||
#:use-module ((guix gexp) #:select (local-file))
|
||||
#:use-module ((guix gexp) #:select (gexp local-file gexp?))
|
||||
#:use-module ((guix utils) #:select (call-with-temporary-directory))
|
||||
#:use-module ((guix import hackage) #:select (%hackage-url))
|
||||
#:use-module ((guix import stackage) #:select (%stackage-url))
|
||||
@ -744,6 +745,80 @@
|
||||
(sha256 %null-sha256))))))
|
||||
(check-source-unstable-tarball pkg)))
|
||||
|
||||
(define (package-with-phase-changes changes)
|
||||
(dummy-package "x"
|
||||
(arguments `(#:phases
|
||||
,(if (gexp? changes)
|
||||
#~(modify-phases %standard-phases
|
||||
#$@changes)
|
||||
`(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 "optional-tests: allow G-exps (no warning)"
|
||||
'()
|
||||
(let ((pkg (package-with-phase-changes #~())))
|
||||
(check-optional-tests pkg)))
|
||||
|
||||
(test-equal "optional-tests: allow G-exps (warning)"
|
||||
"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: complicated 'check' phase"
|
||||
"the 'check' phase should respect #:tests?"
|
||||
(let ((pkg (package-with-phase-changes
|
||||
'((replace 'check
|
||||
(lambda* (#:key inputs tests? #:allow-other-keys)
|
||||
(let ((something (stuff from inputs or native-inputs)))
|
||||
(delete-file "dateutil/test/test_utils.py")
|
||||
(invoke "pytest" "-vv"))))))))
|
||||
(single-lint-warning-message
|
||||
(check-optional-tests pkg))))
|
||||
|
||||
(test-equal "optional-tests: 'check' phase is not first phase"
|
||||
"the 'check' phase should respect #:tests?"
|
||||
(let ((pkg (package-with-phase-changes
|
||||
'((add-after 'unpack
|
||||
(lambda _
|
||||
(chdir "libtestcase-0.0.0")))
|
||||
(replace 'check
|
||||
(lambda _ (invoke "./test-suite")))))))
|
||||
(single-lint-warning-message
|
||||
(check-optional-tests pkg))))
|
||||
|
||||
(test-equal "source: 200"
|
||||
'()
|
||||
(with-http-server `((200 ,%long-string))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user