1 files changed, 60 insertions, 5 deletions
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 1179f1234b..fff795c4d3 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -27,7 +27,10 @@
   #:use-module (rnrs io ports)
   #:export (union-build
 
-            warn-about-collision))
+            warn-about-collision
+
+            relative-file-name
+            symlink-relative))
 
 ;;; Commentary:
 ;;;
@@ -78,14 +81,23 @@ identical, #f otherwise."
                                    (or (eof-object? n1)
                                        (loop))))))))))))))
 
+(define %harmless-collisions
+  ;; This is a list of files that are known to collide, but for which emitting
+  ;; a warning doesn't make sense.  For example, "icon-theme.cache" is
+  ;; regenerated by a profile hook which shadows the file provided by
+  ;; individual packages, and "gschemas.compiled" is made available to
+  ;; applications via 'glib-or-gtk-build-system'.
+  '("icon-theme.cache" "gschemas.compiled"))
+
 (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)
+    (unless (member (basename file) %harmless-collisions)
+      (format (current-error-port)
+              "~%warning: collision encountered:~%~{  ~a~%~}"
+              files)
+      (format (current-error-port) "warning: choosing ~a~%" file))
     file))
 
 (define* (union-build output inputs
@@ -174,4 +186,47 @@ returns #f, skip the faulty file altogether."
 
   (union-of-directories output (delete-duplicates inputs)))
 
+
+;;;
+;;; Relative symlinks.
+;;;
+
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (relative-file-name reference file)
+  "Given REFERENCE and FILE, both of which are absolute file names, return the
+file name of FILE relative to REFERENCE.
+
+  (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
+  => \"../bin/bar\"
+
+Note that this is from a purely lexical standpoint; conversely, \"..\" is
+*not* resolved lexically on POSIX in the presence of symlinks."
+  (if (and (string-prefix? "/" file) (string-prefix? "/" reference))
+      (let loop ((reference (string-tokenize reference %not-slash))
+                 (file      (string-tokenize file %not-slash)))
+        (define (finish)
+          (string-join (append (make-list (length reference) "..") file)
+                       "/"))
+
+        (match reference
+          (()
+           (finish))
+          ((head . tail)
+           (match file
+             (()
+              (finish))
+             ((head* . tail*)
+              (if (string=? head head*)
+                  (loop tail tail*)
+                  (finish)))))))
+      file))
+
+(define (symlink-relative old new)
+  "Assuming both OLD and NEW are absolute file names, make NEW a symlink to
+OLD, but using a relative file name."
+  (symlink (relative-file-name (dirname new) old)
+           new))
+
 ;;; union.scm ends here