bug#63319: [PATCH 1/3] profiles: include non-lowered entries and manifest in collision error.

[Ulf Herrman]

This provides the necessary information for (guix ui) to accurately determine
the actual entries causing the collision.  The entries alone aren't enough,
since they inherit their parent (singular!) field from whatever it happened to
be before any manifest transaction was applied.  The lowered variants are
included because (guix ui) needs them for reporting store paths, and the
non-lowered variants are included so that the proper parents can be derived
from the included manifest, which must contain them.

We also add and export a convenience procedure for finding the parents of menu
entries in a particular manifest.

* guix/profiles.scm (profile-collision-error-entry-lowered,
  profile-collision-error-conflict-lowered, profile-collision-error-manifest):
  new fields.
  (check-for-collisions): populate them.
  (manifest-entry->parents): new procedure.
* guix/ui.scm (call-with-error-handling): use lowered entries.
---
 guix/profiles.scm | 60 ++++++++++++++++++++++++++++++++++++++---------
 guix/ui.scm       |  4 ++--
 2 files changed, 51 insertions(+), 13 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 03333785f9..b812a6f7d9 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -64,7 +64,10 @@ (define-module (guix profiles)
             &profile-collision-error
             profile-collision-error?
             profile-collision-error-entry
+            profile-collision-error-entry-lowered
             profile-collision-error-conflict
+            profile-collision-error-conflict-lowered
+            profile-collision-error-manifest
             &missing-generation-error
             missing-generation-error?
             missing-generation-error-generation
@@ -107,6 +110,7 @@ (define-module (guix profiles)
             manifest-installed?
             manifest-matching-entries
             manifest-search-paths
+            manifest-entry->parents
             check-for-collisions
 
             manifest->code
@@ -186,7 +190,10 @@ (define-condition-type &profile-not-found-error 
&profile-error
 (define-condition-type &profile-collision-error &error
   profile-collision-error?
   (entry    profile-collision-error-entry)        ;<manifest-entry>
-  (conflict profile-collision-error-conflict))    ;<manifest-entry>
+  (conflict profile-collision-error-conflict)     ;<manifest-entry>
+  (entry-lowered profile-collision-error-entry-lowered)       ;<manifest-entry>
+  (conflict-lowered profile-collision-error-conflict-lowered) ;<manifest-entry>
+  (manifest profile-collision-error-manifest))    ;<manifest>
 
 (define-condition-type &unmatched-pattern-error &error
   unmatched-pattern-error?
@@ -329,6 +336,34 @@ (define (recurse entry)
                     (item (derivation->output-path drv output))
                     (dependencies dependencies)))))))
 
+(define (manifest-entry->parents manifest)
+  "Return a procedure that maps each <manifest-entry> in MANIFEST to the list
+of <manifest-entry>s in MANIFEST or their dependencies, recursively, that
+have the entry in question as a direct dependency."
+  (define (visit-entries entries mapping visited?)
+    (match entries
+      (((and entry ($ <manifest-entry> _ _ _ _ dependencies)) . rest)
+       (if (vhash-assq entry visited?)
+           (visit-entries rest mapping visited?)
+           (call-with-values
+               (lambda ()
+                 (visit-entries dependencies
+                                (fold (lambda (dependency mapping)
+                                        (vhash-consq dependency entry mapping))
+                                      mapping
+                                      dependencies)
+                                (vhash-consq entry #t visited?)))
+             (lambda (mapping visited?)
+               (visit-entries rest mapping visited?)))))
+      (()
+       (values mapping visited?))))
+
+  (define mapping
+    (visit-entries (manifest-entries manifest) vlist-null vlist-null))
+
+  (lambda (entry)
+    (vhash-foldq* cons '() entry mapping)))
+
 (define* (check-for-collisions manifest system #:key target)
   "Check whether the entries of MANIFEST conflict with one another; raise a
 '&profile-collision-error' when a conflict is encountered."
@@ -348,25 +383,28 @@ (define candidates
   (define lower-pair
     (match-lambda
       ((first second)
-       (mlet %store-monad ((first  (lower-manifest-entry first system
-                                                         #:target target))
-                           (second (lower-manifest-entry second system
-                                                         #:target target)))
-         (return (list first second))))))
+       (mlet %store-monad ((first-low  (lower-manifest-entry first system
+                                                             #:target target))
+                           (second-low (lower-manifest-entry second system
+                                                             #:target target)))
+         (return (list first first-low second second-low))))))
 
   ;; Start by lowering CANDIDATES "in parallel".
-  (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates)))
+  (mlet* %store-monad ((lst (mapm/accumulate-builds lower-pair candidates)))
     (foldm %store-monad
            (lambda (entries result)
              (match entries
-               ((first second)
-                (if (string=? (manifest-entry-item first)
-                              (manifest-entry-item second))
+               ((first first-low second second-low)
+                (if (string=? (manifest-entry-item first-low)
+                              (manifest-entry-item second-low))
                     (return result)
                     (raise (condition
                             (&profile-collision-error
                              (entry first)
-                             (conflict second))))))))
+                             (entry-lowered first-low)
+                             (conflict second)
+                             (conflict-lowered second-low)
+                             (manifest manifest))))))))
            #t
            lst)))
 
diff --git a/guix/ui.scm b/guix/ui.scm
index d75243458d..5d2ae23c25 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -750,8 +750,8 @@ (define (port-filename* port)
                          ("out" #f)
                          (output output)))))
              ((profile-collision-error? c)
-              (let ((entry    (profile-collision-error-entry c))
-                    (conflict (profile-collision-error-conflict c)))
+              (let ((entry    (profile-collision-error-entry-lowered c))
+                    (conflict (profile-collision-error-conflict-lowered c)))
                 (define (report-parent-entries entry)
                   (let ((parent (force (manifest-entry-parent entry))))
                     (when (manifest-entry? parent)
-- 
2.39.1