gexp: 'gexp-modules' now consistently deletes duplicates.

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.
This commit is contained in:
Ludovic Courtès 2018-10-27 15:45:45 +02:00
parent 003789e837
commit 932d160056
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 37 additions and 4 deletions

View File

@ -506,9 +506,10 @@ whether this should be considered a \"native\" input or not."
(set-record-type-printer! <gexp-output> write-gexp-output) (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 "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) (if (gexp? gexp)
(delete-duplicates (delete-duplicates
(append (self-attribute gexp) (append (self-attribute gexp)
@ -524,13 +525,29 @@ returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
lst)) lst))
(_ (_
'())) '()))
(gexp-references gexp)))) (gexp-references gexp)))
equal?)
'())) ;plain Scheme data type '())) ;plain Scheme data type
(define (gexp-modules gexp) (define (gexp-modules gexp)
"Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is "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." 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) (define (gexp-extensions gexp)
"Return the list of Guile extensions (packages) GEXP relies on. If (gexp? "Return the list of Guile extensions (packages) GEXP relies on. If (gexp?

View File

@ -680,6 +680,22 @@
#~(foo #$@(list (with-imported-modules '((foo)) #~+) #~(foo #$@(list (with-imported-modules '((foo)) #~+)
(with-imported-modules '((bar)) #~-))))) (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" (test-equal "gexp-modules and literal Scheme object"
'() '()
(gexp-modules #t)) (gexp-modules #t))