From c16022f0c18d596678bdba82cd123ba6dae96a60 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Mon, 28 Jun 2021 20:44:16 +0200
Subject: [PATCH v3 2/2] 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.
---
guix/lint.scm | 60 ++++++++++++++++++++++++++++++++++++++-
tests/lint.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 135 insertions(+), 2 deletions(-)
@@ -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)
@@ -88,6 +89,7 @@
check-source
check-source-file-name
check-source-unstable-tarball
+ check-optional-tests
check-mirror-url
check-github-url
check-license
@@ -1050,6 +1052,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)
@@ -1590,6 +1644,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))
--
2.32.0