From 932d1600564cbf359a6ccd1086b968a934bef8e5 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 27 Oct 2018 15:45:45 +0200
Subject: gexp: 'gexp-modules' now consistently deletes duplicates.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Fixes <https://bugs.gnu.org/32966>.
Reported by Clément Lassieur <clement@lassieur.org>.

* guix/gexp.scm (gexp-attribute): Add 'equal?' optional parameter; pass
it to 'delete-duplicates'.
(gexp-modules)[module=?]: New procedure.
Pass it to 'gexp-attribute'.
* tests/gexp.scm ("gexp-modules deletes duplicates"): New test.
---
 guix/gexp.scm  | 25 +++++++++++++++++++++----
 tests/gexp.scm | 16 ++++++++++++++++
 2 files changed, 37 insertions(+), 4 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index ba0d642b17..537875b6b7 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -506,9 +506,10 @@ whether this should be considered a \"native\" input or not."
 
 (set-record-type-printer! <gexp-output> write-gexp-output)
 
-(define (gexp-attribute gexp self-attribute)
+(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?))
   "Recurse on GEXP and the expressions it refers to, summing the items
-returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp.  Use EQUAL? as the
+second argument to 'delete-duplicates'."
   (if (gexp? gexp)
       (delete-duplicates
        (append (self-attribute gexp)
@@ -524,13 +525,29 @@ returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
                                           lst))
                              (_
                               '()))
-                           (gexp-references gexp))))
+                           (gexp-references gexp)))
+       equal?)
       '()))                                       ;plain Scheme data type
 
 (define (gexp-modules gexp)
   "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
 false, meaning that GEXP is a plain Scheme object, return the empty list."
-  (gexp-attribute gexp gexp-self-modules))
+  (define (module=? m1 m2)
+    ;; Return #t when M1 equals M2.  Special-case '=>' specs because their
+    ;; right-hand side may not be comparable with 'equal?': it's typically a
+    ;; file-like object that embeds a gexp, which in turn embeds closure;
+    ;; those closures may be 'eq?' when running compiled code but are unlikely
+    ;; to be 'eq?' when running on 'eval'.  Ignore the right-hand side to
+    ;; avoid this discrepancy.
+    (match m1
+      (((name1 ...) '=> _)
+       (match m2
+         (((name2 ...) '=> _) (equal? name1 name2))
+         (_ #f)))
+      (_
+       (equal? m1 m2))))
+
+  (gexp-attribute gexp gexp-self-modules module=?))
 
 (define (gexp-extensions gexp)
   "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 813ea2ff6f..467370f8cb 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -680,6 +680,22 @@
    #~(foo #$@(list (with-imported-modules '((foo)) #~+)
                    (with-imported-modules '((bar)) #~-)))))
 
+(test-assert "gexp-modules deletes duplicates"   ;<https://bugs.gnu.org/32966>
+  (let ((make-file (lambda ()
+                     ;; Use 'eval' to make sure we get an object that's not
+                     ;; 'eq?' nor 'equal?' due to the closures it embeds.
+                     (eval '(scheme-file "bar.scm" #~(define-module (bar)))
+                           (current-module)))))
+    (define result
+      ((@@ (guix gexp) gexp-modules)
+       (with-imported-modules `(((bar) => ,(make-file))
+                                ((bar) => ,(make-file))
+                                (foo) (foo))
+         #~+)))
+
+    (match result
+      (((('bar) '=> (? scheme-file?)) ('foo)) #t))))
+
 (test-equal "gexp-modules and literal Scheme object"
   '()
   (gexp-modules #t))
-- 
cgit v1.2.3