From e40aa54e98aa6329e6196fd29e7e4e34ce3a063c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 8 Apr 2018 15:47:11 +0200
Subject: union: Allow callers to choose the collision resolution policy.

* guix/build/union.scm (warn-about-collision): New procedure.
(union-build): Add #:resolve-collision.
[resolve-collisions]: Call it.
* tests/union.scm ("union-build collision first & last"): New test.
---
 guix/build/union.scm | 36 ++++++++++++++++++++++++------------
 1 file changed, 24 insertions(+), 12 deletions(-)

(limited to 'guix')

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 5f1cf8e450..1179f1234b 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -25,7 +25,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
-  #:export (union-build))
+  #:export (union-build
+
+            warn-about-collision))
 
 ;;; Commentary:
 ;;;
@@ -76,14 +78,29 @@ identical, #f otherwise."
                                    (or (eof-object? n1)
                                        (loop))))))))))))))
 
+(define (warn-about-collision files)
+  "Handle the collision among FILES by emitting a warning and choosing the
+first one of THEM."
+  (format (current-error-port)
+          "~%warning: collision encountered:~%~{  ~a~%~}"
+          files)
+  (let ((file (first files)))
+    (format (current-error-port) "warning: choosing ~a~%" file)
+    file))
+
 (define* (union-build output inputs
                       #:key (log-port (current-error-port))
                       (create-all-directories? #f)
-                      (symlink symlink))
+                      (symlink symlink)
+                      (resolve-collision warn-about-collision))
   "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
-make sure the caller can modify them later."
+make sure the caller can modify them later.
+
+When two or more regular files collide, call RESOLVE-COLLISION with the list
+of colliding files and use the one that it returns; or, if RESOLVE-COLLISION
+returns #f, skip the faulty file altogether."
 
   (define (symlink* input output)
     (format log-port "`~a' ~~> `~a'~%" input output)
@@ -92,15 +109,10 @@ make sure the caller can modify them later."
   (define (resolve-collisions output dirs files)
     (cond ((null? dirs)
            ;; The inputs are all files.
-           (format (current-error-port)
-                   "~%warning: collision encountered:~%~{  ~a~%~}"
-                   files)
-
-           (let ((file (first files)))
-             ;; TODO: Implement smarter strategies.
-             (format (current-error-port) "warning: choosing ~a~%" file)
-
-             (symlink* file output)))
+           (match (resolve-collision files)
+             (#f #f)
+             ((? string? file)
+              (symlink* file output))))
 
           (else
            ;; The inputs are a mixture of files and directories
-- 
cgit v1.2.3