lint: Add 'check-for-collisions' checker.

Suggested by Edouard Klein <edk@beaver-labs.com>.

* guix/profiles.scm (check-for-collisions): Export.
* guix/lint.scm (check-profile-collisions): New procedure.
(%local-checkers): Add 'profile-collisions' checker.
* tests/lint.scm ("profile-collisions: no warnings")
("profile-collisions: propagated inputs collide")
("profile-collisions: propagated inputs collide, store items"): New tests.
* doc/guix.texi (Invoking guix lint): Document it.

4 files changed, 78 insertions, 0 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index aeeea7896e..333dd703de 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -9957,6 +9957,13 @@ autogenerated tarballs are sometimes regenerated.
 Check that the derivation of the given packages can be successfully
 computed for all the supported systems (@pxref{Derivations}).
 
+@item profile-collisions
+Check whether installing the given packages in a profile would lead to
+collisions.  Collisions occur when several packages with the same name
+but a different version or a different store file name are propagated.
+@xref{package Reference, @code{propagated-inputs}}, for more information
+on propagated inputs.
+
 @item archival
 @cindex Software Heritage, source code archive
 @cindex archival of source code, Software Heritage
diff --git a/guix/lint.scm b/guix/lint.scm
index 82861b8a27..fa507546f5 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -41,6 +41,8 @@
   #:use-module (guix upstream)
   #:use-module (guix utils)
   #:use-module (guix memoization)
+  #:use-module (guix profiles)
+  #:use-module (guix monads)
   #:use-module (guix scripts)
   #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
   #:use-module (guix gnu-maintenance)
@@ -84,6 +86,7 @@
             check-for-updates
             check-formatting
             check-archival
+            check-profile-collisions
 
             lint-warning
             lint-warning?
@@ -970,6 +973,38 @@ descriptions maintained upstream."
       (with-store store
         (check-with-store store))))
 
+(define* (check-profile-collisions package #:key store)
+  "Check for collisions that would occur when installing PACKAGE as a result
+of the propagated inputs it pulls in."
+  (define (do-check store)
+    (guard (c ((profile-collision-error? c)
+               (let ((first  (profile-collision-error-entry c))
+                     (second (profile-collision-error-conflict c)))
+                 (define format
+                   (if (string=? (manifest-entry-version first)
+                                 (manifest-entry-version second))
+                       manifest-entry-item
+                       (lambda (entry)
+                         (string-append (manifest-entry-name entry) "@"
+                                        (manifest-entry-version entry)))))
+
+                 (list (make-warning package
+                                     (G_ "propagated inputs ~a and ~a collide")
+                                     (list (format first)
+                                           (format second)))))))
+      ;; Disable grafts to avoid building PACKAGE and its dependencies.
+      (parameterize ((%graft? #f))
+        (run-with-store store
+          (mbegin %store-monad
+            (check-for-collisions (packages->manifest (list package))
+                                  (%current-system))
+            (return '()))))))
+
+  (if store
+      (do-check store)
+      (with-store store
+        (do-check store))))
+
 (define (check-license package)
   "Warn about type errors of the 'license' field of PACKAGE."
   (match (package-license package)
@@ -1350,6 +1385,11 @@ or a list thereof")
      (check           check-derivation)
      (requires-store? #t))
    (lint-checker
+     (name            'profile-collisions)
+     (description     "Report collisions that would occur due to propagated inputs")
+     (check           check-profile-collisions)
+     (requires-store? #t))
+   (lint-checker
     (name        'patch-file-names)
     (description "Validate file names and availability of patches")
     (check       check-patch-file-names))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 6064820b9a..9df63c97e9 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -104,6 +104,7 @@
             manifest-installed?
             manifest-matching-entries
             manifest-search-paths
+            check-for-collisions
 
             manifest-transaction
             manifest-transaction?
diff --git a/tests/lint.scm b/tests/lint.scm
index 4ce45b4a70..9d3c349fc5 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -353,6 +353,36 @@
     (((and (? lint-warning?) first-warning) others ...)
      (lint-warning-message first-warning))))
 
+(test-equal "profile-collisions: no warnings"
+  '()
+  (check-profile-collisions (dummy-package "x")))
+
+(test-equal "profile-collisions: propagated inputs collide"
+  "propagated inputs p0@1 and p0@2 collide"
+  (let* ((p0  (dummy-package "p0" (version "1")))
+         (p0* (dummy-package "p0" (version "2")))
+         (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
+         (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
+         (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
+         (p4  (dummy-package "p4" (propagated-inputs
+                                   `(("p2" ,p2) ("p3", p3))))))
+    (single-lint-warning-message
+     (check-profile-collisions p4))))
+
+(test-assert "profile-collisions: propagated inputs collide, store items"
+  (string-match-or-error
+   "propagated inputs /[[:graph:]]+-p0-1 and /[[:graph:]]+-p0-1 collide"
+   (let* ((p0  (dummy-package "p0" (version "1")))
+          (p0* (dummy-package "p0" (version "1")
+                              (inputs `(("x" ,(dummy-package "x"))))))
+          (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
+          (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
+          (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
+          (p4  (dummy-package "p4" (propagated-inputs
+                                    `(("p2" ,p2) ("p3", p3))))))
+     (single-lint-warning-message
+      (check-profile-collisions p4)))))
+
 (test-equal "license: invalid license"
   "invalid license field"
   (single-lint-warning-message