diff options
| -rw-r--r-- | guix/lint.scm | 60 | ||||
| -rw-r--r-- | tests/lint.scm | 77 |
2 files changed, 135 insertions, 2 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)) diff --git a/tests/lint.scm b/tests/lint.scm index fae346e724..4ef400a9a0 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -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)) |