Improve package deduplicationtrunk

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.

1 files changed, 79 insertions, 42 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 4d5eb7e..75400b2 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -641,48 +641,85 @@
 
 (define (sort-and-deduplicate-inferior-packages packages
                                                 pkg-to-replacement-hash-table)
-  (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)))
-           (if (and (string=? a-name b-name)
-                    (string=? a-version b-version)
-                    (eq? a-replacement b-replacement))
-               (begin
-                 (simple-format (current-error-port)
-                                "warning: ignoring duplicate package: ~A (~A)\n"
-                                a-name
-                                a-version)
-                 result)
-               (cons a result)))))
-   '()
-   (sort packages
-         (lambda (a b)
-           (let ((a-name (inferior-package-name a))
-                 (b-name (inferior-package-name b)))
-             (if (string=? a-name b-name)
-                 (let ((a-version (inferior-package-version a))
-                       (b-version (inferior-package-version b)))
-                   (if (string=? a-version b-version)
-                       ;; The name and version are the same, so try and pick
-                       ;; the same package each time, by looking at the
-                       ;; location.
-                       (let ((a-location (inferior-package-location a))
-                             (b-location (inferior-package-location b)))
-                         (> (location-line a-location)
-                            (location-line b-location)))
-                       (string<? a-version
-                                 b-version)))
-                 (string<? a-name
-                           b-name)))))))
+  (let ((sorted-packages
+         (sort packages
+               (lambda (a b)
+                 (let ((a-name (inferior-package-name a))
+                       (b-name (inferior-package-name b)))
+                   (if (string=? a-name b-name)
+                       (let ((a-version (inferior-package-version a))
+                             (b-version (inferior-package-version b)))
+                         (if (string=? a-version b-version)
+                             (let ((a-replacement (hashq-ref pkg-to-replacement-hash-table a))
+                                   (b-replacement (hashq-ref pkg-to-replacement-hash-table b)))
+                               (if (or (and a-replacement b-replacement)
+                                       (and (eq? #f a-replacement)
+                                            (eq? #f b-replacement)))
+                                   ;; The name and version are the same, so try and
+                                   ;; pick the same package each time, by looking at
+                                   ;; the location.
+                                   (let ((a-location (inferior-package-location a))
+                                         (b-location (inferior-package-location b)))
+                                     (> (location-line a-location)
+                                        (location-line b-location)))
+                                   (->bool a-replacement)))
+                             (string<? a-version
+                                       b-version)))
+                       (string<? a-name
+                                 b-name)))))))
+
+    (define (print-packages-matching-name-and-version name version)
+      (simple-format (current-error-port) "packages matching: ~A@~A\n"
+                     name version)
+      (for-each
+       (lambda (pkg)
+         (when (and (string=? (inferior-package-name pkg)
+                              name)
+                    (string=? (inferior-package-version pkg)
+                              version))
+           (simple-format
+            (current-error-port)
+            " - ~A@~A (replacement: ~A, location: ~A)\n"
+            name
+            version
+            (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)
   (let* ((packages