06/06: guix: build: Factor out default collision-resolver.

[guix-commits]

lilyp pushed a commit to branch core-updates
in repository guix.

commit 42e3089752b9fdfd0569b990085fc1cd5cd75f77
Author: Attila Lendvai <attila@lendvai.name>
AuthorDate: Sun Oct 3 14:43:02 2021 +0200

    guix: build: Factor out default collision-resolver.
    
    This prepares the stage for new collision resolvers without changing the
    underlying semantics too much.
    
    * guix/build/union.scm (resolve+warn-if-harmful): New variable.
    (warn-about-collision): Rename to...
    (resolve-collision/default): ... this.  Implement in terms of
    resolve+warn-if-harmful.
    (union-build): Adjust accordingly.
    * guix/gexp.scm (directory-union): Likewise.
    
    Signed-off-by: Liliana Marie Prikler <liliana.prikler@gmail.com>
---
 guix/build/union.scm | 25 +++++++++++++++++--------
 guix/gexp.scm        |  2 +-
 2 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/guix/build/union.scm b/guix/build/union.scm
index bf75c67c52..ce6d030109 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -27,7 +27,7 @@
   #:use-module (rnrs io ports)
   #:export (union-build
 
-            warn-about-collision
+            resolve-collision/default
 
             relative-file-name
             symlink-relative))
@@ -103,22 +103,31 @@ identical, #f otherwise."
   ;; for most packages.
   '("icon-theme.cache" "gschemas.compiled" "ld.so.cache"))
 
-(define (warn-about-collision files)
-  "Handle the collision among FILES by emitting a warning and choosing the
-first one of THEM."
-  (let ((file (first files)))
-    (unless (member (basename file) %harmless-collisions)
+(define (resolve+warn-if-harmful resolve files)
+  "Same as (resolve files), but print a warning if the resolved file is not
+considered harmless.  Also warn if the resolver doesn't pick any file."
+  (let ((file (resolve files)))
+    (cond
+     ((not file)
       (format (current-error-port)
               "~%warning: collision encountered:~%~{  ~a~%~}"
               files)
-      (format (current-error-port) "warning: choosing ~a~%" file))
+      (format (current-error-port) "warning: not choosing any file~%"))
+     (((negate member) (basename file) %harmless-collisions)
+      (format (current-error-port)
+              "~%warning: collision encountered:~%~{  ~a~%~}"
+              files)
+      (format (current-error-port) "warning: choosing ~a~%" file)))
     file))
 
+(define (resolve-collision/default files)
+  (resolve+warn-if-harmful first files))
+
 (define* (union-build output inputs
                       #:key (log-port (current-error-port))
                       (create-all-directories? #f)
                       (symlink symlink)
-                      (resolve-collision warn-about-collision))
+                      (resolve-collision resolve-collision/default))
   "Build in the OUTPUT directory a symlink tree that is the union of all the
 INPUTS, using SYMLINK to create symlinks.  As a special case, if
 CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 73595a216b..a50b93ed48 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -2128,7 +2128,7 @@ This yields an 'etc' directory containing these two 
files."
 
 (define* (directory-union name things
                           #:key (copy? #f) (quiet? #f)
-                          (resolve-collision 'warn-about-collision))
+                          (resolve-collision 'resolve-collision/default))
   "Return a directory that is the union of THINGS, where THINGS is a list of
 file-like objects denoting directories.  For example: