GNU bug report logs - #48320
[PATCH] lint: Verify if #:tests? is respected in the 'check' phase.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 48320 in the body.
You can then email your comments to 48320 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Maxime Devos <maximedevos <at> telenet.be>
To: guix-patches <at> gnu.org
Subject: [PATCH] lint: Verify if #:tests? is respected in the 'check' phase.
Date: Sun, 09 May 2021 20:02:12 +0200

[Message part 1 (text/plain, inline)]

Hi guix,

There have been a few patches to the mailing list lately not
respecting this, and this linter detects 325 package definitions
that could be modified to support the --without-tests package
transformation.

Copyright lines were added in the previous patch I sent to guix-patches
today.

Greetings,
Maxime

[0001-lint-Verify-if-tests-is-respected-in-the-check-phase.patch (text/x-patch, attachment)]

[signature.asc (application/pgp-signature, inline)]

Message #8 received at 48320 <at> debbugs.gnu.org (full text, mbox):

From: Mathieu Othacehe <othacehe <at> gnu.org>
To: Maxime Devos <maximedevos <at> telenet.be>
Cc: 48320 <at> debbugs.gnu.org
Subject: Re: bug#48320: [PATCH] lint: Verify if #:tests? is respected in the
 'check' phase.
Date: Fri, 18 Jun 2021 14:15:50 +0200

Hello Maxime,

> +      (`(,(or 'lambda 'lambda*) ,_ (invoke . ,_) . ,_)
> +       (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)))

I like the idea behind this patch. However I think the detection pattern
could be improved for instance, here are a few unreported packages:

- dejagnu
- python-dateutil
- eigen

Maybe we should check directly if the tests? variable is used within the
'check replace phase?

Thanks,

Mathieu

Message #11 received at 48320 <at> debbugs.gnu.org (full text, mbox):

From: Maxime Devos <maximedevos <at> telenet.be>
To: Mathieu Othacehe <othacehe <at> gnu.org>
Cc: 48320 <at> debbugs.gnu.org
Subject: Re: bug#48320: [PATCH] lint: Verify if #:tests? is respected in the
 'check' phase.
Date: Fri, 18 Jun 2021 17:34:17 +0200

[Message part 1 (text/plain, inline)]

Mathieu Othacehe schreef op vr 18-06-2021 om 14:15 [+0200]:
> Hello Maxime,
> 
> > +      (`(,(or 'lambda 'lambda*) ,_ (invoke . ,_) . ,_)
> > +       (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)))

I just noticed the following test case in (tests lint) is somewhat bogus:

> +              '((replace 'check+
> +                  (lambda (#:key tests? #:allow-other-keys?)

Instead of 'lambda', this should be 'lambda*'.

Also, the value for #:phases can now be a G-expression,
so the usage of 'package-arguments' in the patch would need to be adjusted
as well.

> I like the idea behind this patch. However I think the detection pattern
> could be improved for instance, here are a few unreported packages:
> 
> - dejagnu
> - python-dateutil
> - eigen
> 
> Maybe we should check directly if the tests? variable is used within the
> 'check replace phase?

So, basically, test if applying the following procedure to the body
succeeds?

(define (sexp-uses-tests?? sexp)
  (sexp-contains-atom? sexp 'tests?))

(define (sexp-contains-atom? sexp atom)
  ; atoms are compared with eq? and vectors are currently not supported
  (if (pair? sexp)
      (or (sexp-contains? sexp atom)
          (sexp-contains? sexp atom))
      (eq? sexp atom)))

That seems a good improvement for a v2.

Thanks,
Maxime.

[signature.asc (application/pgp-signature, inline)]

Message #14 received at 48320 <at> debbugs.gnu.org (full text, mbox):

From: Maxime Devos <maximedevos <at> telenet.be>
To: 48320 <at> debbugs.gnu.org
Cc: Mathieu Othacehe <othacehe <at> gnu.org>
Subject: [PATCH v2] lint: Verify if #:tests? is respected in the 'check' phase.
Date: Mon, 28 Jun 2021 23:15:42 +0200

[Message part 1 (text/plain, inline)]

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.

[v2-0001-guix-gexp-Define-gexp-approximate-sexp.patch (text/x-patch, inline)]

From 8e898a6c0f3dfa086f1414115fb2f58fe36224b1 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos <at> telenet.be>
Date: Mon, 28 Jun 2021 19:24:44 +0200
Subject: [PATCH v2 1/2] guix: gexp: Define gexp->approximate-sexp.
To: 48320 <at> debbugs.gnu.org
Cc: Mathieu Othacehe <othacehe <at> 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 <at> gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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 <at> gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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

[v2-0002-lint-Verify-if-tests-is-respected-in-the-check-ph.patch (text/x-patch, inline)]

From 604cd00c3fcce436d23f05ff7496a6ea1200594e Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos <at> 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 <at> debbugs.gnu.org
Cc: Mathieu Othacehe <othacehe <at> 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 <at> systemreboot.net>
 ;;; Copyright © 2020 Timothy Sample <samplet <at> ngyro.com>
 ;;; Copyright © 2021 Xinglu Chen <public <at> yoctocell.xyz>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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 (application/pgp-signature, inline)]

Message #17 received at 48320 <at> debbugs.gnu.org (full text, mbox):

From: Mathieu Othacehe <othacehe <at> gnu.org>
To: Maxime Devos <maximedevos <at> telenet.be>
Cc: 48320 <at> debbugs.gnu.org
Subject: Re: [PATCH v2] lint: Verify if #:tests? is respected in the 'check'
 phase.
Date: Tue, 29 Jun 2021 12:34:48 +0200

Hello Maxime,

Thanks for the new revision.

> +@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})

You can write longer sentences here, up to 78 columns.  If you are using
Emacs, fill-paragraph does the right thing.

> +  (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)))

It would make more sense to define "sexp-uses-tests??" later as it uses
"sexp-contains-atom" that is defined afterwards.

> +       (or (check-phases-delta head)
> +           (check-phases-deltas tail)))

I think it should be "append" instead of "or". Otherwise, it fails to
detect package which 'replace is not the first phase, see mkvtoolnix for
instance.

Otherwise looks fine :)

Thanks,

Mathieu

Message #20 received at 48320 <at> debbugs.gnu.org (full text, mbox):

From: Maxime Devos <maximedevos <at> telenet.be>
To: Mathieu Othacehe <othacehe <at> gnu.org>
Cc: 48320 <at> debbugs.gnu.org
Subject: [PATCH v3] lint: Verify if #:tests? is respected in the 'check' phase.
Date: Wed, 30 Jun 2021 12:31:57 +0200

[Message part 1 (text/plain, inline)]

Mathieu Othacehe schreef op di 29-06-2021 om 12:34 [+0200]:
> Hello Maxime,
> 
> Thanks for the new revision.
> 
> > +@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})
> 
> You can write longer sentences here, up to 78 columns.  If you are using
> Emacs, fill-paragraph does the right thing.

I did a "fill-paragraph" in the v3.

> > +  (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)))
> 
> It would make more sense to define "sexp-uses-tests??" later as it uses
> "sexp-contains-atom" that is defined afterwards.

Indeed. I switched these two procedures around in the v3.

> > +       (or (check-phases-delta head)
> > +           (check-phases-deltas tail)))
> 
> I think it should be "append" instead of "or". Otherwise, it fails to
> detect package which 'replace is not the first phase, see mkvtoolnix for
> instance.

Indeed. I added a test case and replaced "or" with "append". The linter
now detects about 300 additional cases.

Greetings,
Maxime.

[v3-0001-guix-gexp-Define-gexp-approximate-sexp.patch (text/x-patch, inline)]

From 5835b32d916681db73fb2d91b3646d915bfbd0a8 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos <at> telenet.be>
Date: Mon, 28 Jun 2021 19:24:44 +0200
Subject: [PATCH v3 1/2] guix: gexp: Define gexp->approximate-sexp.

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  | 10 ++++++++++
 guix/gexp.scm  | 19 +++++++++++++++++++
 tests/gexp.scm | 31 +++++++++++++++++++++++++++++++
 3 files changed, 60 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 15e8999447..f051373571 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10038,6 +10038,16 @@ 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 <at> gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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 <at> gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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

[v3-0002-lint-Verify-if-tests-is-respected-in-the-check-ph.patch (text/x-patch, inline)]

From c16022f0c18d596678bdba82cd123ba6dae96a60 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos <at> 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(-)

diff --git a/guix/lint.scm b/guix/lint.scm
index d65d5ce8f9..c637929c38 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-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")
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 <at> systemreboot.net>
 ;;; Copyright © 2020 Timothy Sample <samplet <at> ngyro.com>
 ;;; Copyright © 2021 Xinglu Chen <public <at> yoctocell.xyz>
+;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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

[signature.asc (application/pgp-signature, inline)]

Message #25 received at 48320-done <at> debbugs.gnu.org (full text, mbox):

From: Mathieu Othacehe <othacehe <at> gnu.org>
To: Maxime Devos <maximedevos <at> telenet.be>
Cc: 48320-done <at> debbugs.gnu.org
Subject: Re: [PATCH v3] lint: Verify if #:tests? is respected in the 'check'
 phase.
Date: Wed, 30 Jun 2021 13:55:32 +0200

Hey,

> Indeed. I added a test case and replaced "or" with "append". The linter
> now detects about 300 additional cases.

Great, pushed on master. We now have some work to fix those ~600
packages!

Thanks,

Mathieu

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.