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:
parent
003789e837
commit
932d160056
|
@ -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?
|
||||||
|
|
|
@ -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))
|
||||||
|
|
Loading…
Reference in New Issue