[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#48320] [PATCH v2] lint: Verify if #:tests? is respected in the 'che
From: |
Maxime Devos |
Subject: |
[bug#48320] [PATCH v2] lint: Verify if #:tests? is respected in the 'check' phase. |
Date: |
Mon, 28 Jun 2021 23:15:42 +0200 |
User-agent: |
Evolution 3.34.2 |
Hi Guix,
This is a v2. It detects some more cases
(e.g. python-dateutil dejagnu and eigen).
It also allows letting '#:phases' be
a G-exp.
With thanks to Mathieu Othacehe.
Greetings,
Maxime.
From 8e898a6c0f3dfa086f1414115fb2f58fe36224b1 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Mon, 28 Jun 2021 19:24:44 +0200
Subject: [PATCH v2 1/2] guix: gexp: Define gexp->approximate-sexp.
To: 48320@debbugs.gnu.org
Cc: Mathieu Othacehe <othacehe@gnu.org>
It will be used in the 'optional-tests' linter.
* guix/gexp.scm (gexp->approximate-sexp): New procedure.
* tests/gexp.scm
("no references", "unquoted gexp", "unquoted gexp (native)")
("spliced gexp", "unspliced gexp, approximated")
("unquoted gexp, approximated"): Test it.
* doc/gexp.scm ("G-Expressions"): Document it.
---
doc/guix.texi | 11 +++++++++++
guix/gexp.scm | 19 +++++++++++++++++++
tests/gexp.scm | 31 +++++++++++++++++++++++++++++++
3 files changed, 61 insertions(+)
diff --git a/doc/guix.texi b/doc/guix.texi
index 15e8999447..cc81c417a0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10038,6 +10038,17 @@ corresponding to @var{obj} for @var{system},
cross-compiling for
has an associated gexp compiler, such as a @code{<package>}.
@end deffn
+@deffn {Procedure} gexp->approximate-sexp @var{gexp}
+Sometimes, it may be useful to convert a G-exp into a S-exp.
+For example, some linters (@pxref{Invoking guix lint})
+peek into the build phases of a package to detect potential
+problems. This conversion can be achieved with this
+procedure. However, some information can be lost in the
+process. More specifically, lowerable objects will be silently
+replaced with some arbitrary object -- currently the list
+@code{(*approximate*)}, but this may change.
+@end deffn
+
@node Invoking guix repl
@section Invoking @command{guix repl}
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 187f5c5e85..f3d278b3e6 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -42,6 +43,7 @@
with-imported-modules
with-extensions
let-system
+ gexp->approximate-sexp
gexp-input
gexp-input?
@@ -157,6 +159,23 @@
"Return the source code location of GEXP."
(and=> (%gexp-location gexp) source-properties->location))
+(define* (gexp->approximate-sexp gexp)
+ "Return the S-expression corresponding to GEXP, but do not lower anything.
+As a result, the S-expression will be approximate if GEXP has references."
+ (define (gexp-like? thing)
+ (or (gexp? thing) (gexp-input? thing)))
+ (apply (gexp-proc gexp)
+ (map (lambda (reference)
+ (match reference
+ (($ <gexp-input> thing output native)
+ (if (gexp-like? thing)
+ (gexp->approximate-sexp thing)
+ ;; Simply returning 'thing' won't work in some
+ ;; situations; see 'write-gexp' below.
+ '(*approximate*)))
+ (_ '(*approximate*))))
+ (gexp-references gexp))))
+
(define (write-gexp gexp port)
"Write GEXP on PORT."
(display "#<gexp " port)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 834e78b9a0..39a47d4e8c 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès
<ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -89,6 +90,36 @@
(test-begin "gexp")
+(test-equal "no references"
+ '(display "hello gexp->approximate-sexp!")
+ (gexp->approximate-sexp #~(display "hello gexp->approximate-sexp!")))
+
+(test-equal "unquoted gexp"
+ '(display "hello")
+ (let ((inside #~"hello"))
+ (gexp->approximate-sexp #~(display #$inside))))
+
+(test-equal "unquoted gexp (native)"
+ '(display "hello")
+ (let ((inside #~"hello"))
+ (gexp->approximate-sexp #~(display #+inside))))
+
+(test-equal "spliced gexp"
+ '(display '(fresh vegetables))
+ (let ((inside #~(fresh vegetables)))
+ (gexp->approximate-sexp #~(display '(#$@inside)))))
+
+(test-equal "unspliced gexp, approximated"
+ ;; (*approximate*) is really an implementation detail
+ '(display '(*approximate*))
+ (let ((inside (file-append coreutils "/bin/hello")))
+ (gexp->approximate-sexp #~(display '(#$@inside)))))
+
+(test-equal "unquoted gexp, approximated"
+ '(display '(*approximate*))
+ (let ((inside (file-append coreutils "/bin/hello")))
+ (gexp->approximate-sexp #~(display '#$inside))))
+
(test-equal "no refs"
'(display "hello!")
(let ((exp (gexp (display "hello!"))))
--
2.32.0
From 604cd00c3fcce436d23f05ff7496a6ea1200594e Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Mon, 28 Jun 2021 20:44:16 +0200
Subject: [PATCH v2 2/2] lint: Verify if #:tests? is respected in the 'check'
phase.
To: 48320@debbugs.gnu.org
Cc: Mathieu Othacehe <othacehe@gnu.org>
There have been a few patches to the mailing list lately
not respecting this, and this linter detects 368 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"): New tests.
---
guix/lint.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++-
tests/lint.scm | 66 +++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 124 insertions(+), 2 deletions(-)
diff --git a/guix/lint.scm b/guix/lint.scm
index d65d5ce8f9..7fdc330306 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)
@@ -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-uses-tests?? sexp)
+ "Test if SEXP contains the symbol 'tests?'."
+ (sexp-contains-atom? sexp 'tests?))
+ (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 (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)
+ (or (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")
diff --git a/tests/lint.scm b/tests/lint.scm
index fae346e724..33705f7cd3 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,69 @@
(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 "source: 200"
'()
(with-http-server `((200 ,%long-string))
--
2.32.0
signature.asc
Description: This is a digitally signed message part
- [bug#48320] [PATCH v2] lint: Verify if #:tests? is respected in the 'check' phase.,
Maxime Devos <=