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

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

[Maxime Devos]

[-- Attachment #1.1: Type: text/plain, Size: 325 bytes --]

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

[-- Attachment #1.2: 0001-lint-Verify-if-tests-is-respected-in-the-check-phase.patch --]
[-- Type: text/x-patch, Size: 5061 bytes --]

From 77f6fdb0158d76af9a6789bd0da45ac852ee2868 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sun, 9 May 2021 19:53:31 +0200
Subject: [PATCH] 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 325 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 phase respects #:tests?")
  ("optional-tests: check phase ignores #:tests?")
  ("optional-tests: do not crash when #:phases is invalid"): New tests.
---
 guix/lint.scm  | 40 ++++++++++++++++++++++++++++++++++++++++
 tests/lint.scm | 31 +++++++++++++++++++++++++++++++
 2 files changed, 71 insertions(+)

diff --git a/guix/lint.scm b/guix/lint.scm
index d1cbc9d300..f5db4664dc 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -87,6 +87,7 @@
             check-source
             check-source-file-name
             check-source-unstable-tarball
+            check-optional-tests
             check-mirror-url
             check-github-url
             check-license
@@ -963,6 +964,41 @@ descriptions maintained upstream."
                     (origin-uris origin))
         '())))
 
+(define (check-optional-tests package)
+  "Emit a warning if the test suite is run unconditionally."
+  (define (check-check-procedure expression)
+    (match expression
+      (`(,(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)))
+      ;; The 'check' phase seems ok, stop searching for a bug in this package
+      ;; definition.
+      (_ '())))
+  (define (check-phases-delta delta)
+    (match delta
+      (`(replace 'check ,expression)
+       (check-check-procedure expression))
+      (_ #f)))
+  (define (check-phases-deltas deltas)
+    (match deltas
+      (() '())
+      ((head . tail)
+       (or (check-phases-delta head)
+           (check-phases-deltas tail)))
+      (_ (list (make-warning package
+                             (G_ "incorrect call to modify-phases")
+                             #:field 'arguments)))))
+  (apply (lambda* (#:key phases #:allow-other-keys)
+           (match phases
+             (`(modify-phases ,_ . ,changes)
+              (check-phases-deltas changes))
+             (_ '())))
+         (package-arguments package)))
+
 (define (check-mirror-url package)
   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
   (define (check-mirror-uri uri)                  ;XXX: could be optimized
@@ -1529,6 +1565,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 d6e877d0d7..c9cd6366ec 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -731,6 +731,37 @@
                                (sha256 %null-sha256))))))
     (check-source-unstable-tarball pkg)))
 
+(define (package-with-phase-changes changes)
+  (dummy-package "x"
+                 (arguments `(#:phases
+                              (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 "source: 200"
   '()
   (with-http-server `((200 ,%long-string))
-- 
2.31.1


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

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

[Mathieu Othacehe]

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

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

[Maxime Devos]

[-- Attachment #1: Type: text/plain, Size: 1673 bytes --]

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.

[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

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

[Maxime Devos]

[-- Attachment #1.1: Type: text/plain, Size: 204 bytes --]

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.

[-- Attachment #1.2: v2-0001-guix-gexp-Define-gexp-approximate-sexp.patch --]
[-- Type: text/x-patch, Size: 4858 bytes --]

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 @@
 \f
 (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


[-- Attachment #1.3: v2-0002-lint-Verify-if-tests-is-respected-in-the-check-ph.patch --]
[-- Type: text/x-patch, Size: 8392 bytes --]

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


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

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

[Mathieu Othacehe]

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

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

[Maxime Devos]

[-- Attachment #1.1: Type: text/plain, Size: 1463 bytes --]

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.

[-- Attachment #1.2: v3-0001-guix-gexp-Define-gexp-approximate-sexp.patch --]
[-- Type: text/x-patch, Size: 4791 bytes --]

From 5835b32d916681db73fb2d91b3646d915bfbd0a8 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@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@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 @@
 \f
 (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


[-- Attachment #1.3: v3-0002-lint-Verify-if-tests-is-respected-in-the-check-ph.patch --]
[-- Type: text/x-patch, Size: 8820 bytes --]

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

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@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


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

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

[Mathieu Othacehe]

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