cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve package deduplication

Browse source 
Handle cases where there are up to 4 packages with the same name and version
plus some having replacements. This is currently the case with glibc.
This commit is contained in:
Christopher Baines 2025-02-25 11:23:23 +00:00
parent e591346684
commit 5684add77e
1 changed files with 79 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

121
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -641,48 +641,85 @@
(define (sort-and-deduplicate-inferior-packages packages (define (sort-and-deduplicate-inferior-packages packages
pkg-to-replacement-hash-table) pkg-to-replacement-hash-table)
(pair-fold (let ((sorted-packages
(lambda (pair result) (sort packages
(if (null? (cdr pair)) (lambda (a b)
(cons (first pair) result) (let ((a-name (inferior-package-name a))
(let* ((a (first pair)) (b-name (inferior-package-name b)))
(b (second pair)) (if (string=? a-name b-name)
(a-name (inferior-package-name a)) (let ((a-version (inferior-package-version a))
(b-name (inferior-package-name b)) (b-version (inferior-package-version b)))
(a-version (inferior-package-version a)) (if (string=? a-version b-version)
(b-version (inferior-package-version b)) (let ((a-replacement (hashq-ref pkg-to-replacement-hash-table a))
(a-replacement (hashq-ref pkg-to-replacement-hash-table a)) (b-replacement (hashq-ref pkg-to-replacement-hash-table b)))
(b-replacement (hashq-ref pkg-to-replacement-hash-table b))) (if (or (and a-replacement b-replacement)
(if (and (string=? a-name b-name) (and (eq? #f a-replacement)
(string=? a-version b-version) (eq? #f b-replacement)))
(eq? a-replacement b-replacement)) ;; The name and version are the same, so try and
(begin ;; pick the same package each time, by looking at
(simple-format (current-error-port) ;; the location.
"warning: ignoring duplicate package: ~A (~A)\n" (let ((a-location (inferior-package-location a))
a-name (b-location (inferior-package-location b)))
a-version) (> (location-line a-location)
result) (location-line b-location)))
(cons a result))))) (->bool a-replacement)))
'() (string<? a-version
(sort packages b-version)))
(lambda (a b) (string<? a-name
(let ((a-name (inferior-package-name a)) b-name)))))))
(b-name (inferior-package-name b)))
(if (string=? a-name b-name) (define (print-packages-matching-name-and-version name version)
(let ((a-version (inferior-package-version a)) (simple-format (current-error-port) "packages matching: ~A@~A\n"
(b-version (inferior-package-version b))) name version)
(if (string=? a-version b-version) (for-each
;; The name and version are the same, so try and pick (lambda (pkg)
;; the same package each time, by looking at the (when (and (string=? (inferior-package-name pkg)
;; location. name)
(let ((a-location (inferior-package-location a)) (string=? (inferior-package-version pkg)
(b-location (inferior-package-location b))) version))
(> (location-line a-location) (simple-format
(location-line b-location))) (current-error-port)
(string<? a-version " - ~A@~A (replacement: ~A, location: ~A)\n"
b-version))) name
(string<? a-name version
b-name))))))) (hashq-ref pkg-to-replacement-hash-table pkg)
(inferior-package-location pkg))))
sorted-packages))
(pair-fold
(lambda (pair result)
(if (null? (cdr pair))
(cons (first pair) result)
(let* ((a (first pair))
(b (second pair))
(a-name (inferior-package-name a))
(b-name (inferior-package-name b))
(a-version (inferior-package-version a))
(b-version (inferior-package-version b))
(a-replacement (hashq-ref pkg-to-replacement-hash-table a))
(b-replacement (hashq-ref pkg-to-replacement-hash-table b))
(a-location (inferior-package-location a))
(b-location (inferior-package-location b)))
(if (and (string=? a-name b-name)
(string=? a-version b-version)
(or
(and a-replacement b-replacement)
(and (eq? #f a-replacement)
(eq? #f b-replacement))))
(begin
(simple-format (current-error-port)
"warning: ignoring duplicate package: ~A@~A (replacement: ~A, location: ~A)\n"
a-name
a-version
a-replacement
(location-line a-location))
(print-packages-matching-name-and-version
a-name
a-version)
result)
(cons a result)))))
'()
sorted-packages)))
(define (inferior-packages-plus-replacements inf) (define (inferior-packages-plus-replacements inf)
(let* ((packages (let* ((packages