summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/build/union.scm66
-rw-r--r--tests/union.scm21
2 files changed, 83 insertions, 4 deletions
diff --git a/guix/build/union.scm b/guix/build/union.scm
index ffd367917a..d1578a6ef5 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -1,5 +1,5 @@
;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
-;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright (C) 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guix.
;;;
@@ -19,9 +19,11 @@
(define-module (guix build union)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (tree-union
+ delete-duplicate-leaves
union-build))
;;; Commentary:
@@ -56,6 +58,48 @@ itself a tree. "
'()
(delete-duplicates (map car dirs)))))))))
+(define* (delete-duplicate-leaves tree
+ #:optional
+ (leaf=? equal?)
+ (delete-duplicates (match-lambda
+ ((head _ ...) head))))
+ "Delete duplicate leaves from TREE. Two leaves are considered equal
+when LEAF=? applied to them returns #t. Each collision (list of leaves
+that are LEAF=?) is passed to DELETE-DUPLICATES, which must return a
+single leaf."
+ (let loop ((tree tree))
+ (match tree
+ ((dir children ...)
+ (let ((dirs (filter pair? children))
+ (leaves (remove pair? children)))
+ (define collisions
+ (fold (lambda (leaf result)
+ (define same?
+ (cut leaf=? leaf <>))
+
+ (if (any (cut find same? <>) result)
+ result
+ (match (filter same? leaves)
+ ((_)
+ result)
+ ((collision ...)
+ (cons collision result)))))
+ '()
+ leaves))
+
+ (define non-collisions
+ (filter (lambda (leaf)
+ (match (filter (cut leaf=? leaf <>) leaves)
+ ((_) #t)
+ ((_ _ ..1) #f)))
+ leaves))
+
+ `(,dir
+ ,@non-collisions
+ ,@(map delete-duplicates collisions)
+ ,@(map loop dirs))))
+ (leaf leaf))))
+
(define* (union-build output directories)
"Build in the OUTPUT directory a symlink tree that is the union of all
the DIRECTORIES."
@@ -88,12 +132,28 @@ the DIRECTORIES."
(((? string?) leaves ...)
leaves)))
+ (define (leaf=? a b)
+ (equal? (basename a) (basename b)))
+
+ (define (resolve-collision leaves)
+ ;; LEAVES all have the same basename, so choose one of them.
+ (format (current-error-port) "warning: collision encountered: ~{~a ~}~%"
+ leaves)
+
+ ;; TODO: Implement smarter strategies.
+ (format (current-error-port) "warning: arbitrarily choosing ~a~%"
+ (car leaves))
+ (car leaves))
+
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(mkdir output)
- (let loop ((tree (tree-union (append-map (compose tree-leaves file-tree)
- directories)))
+ (let loop ((tree (delete-duplicate-leaves
+ (tree-union (append-map (compose tree-leaves file-tree)
+ directories))
+ leaf=?
+ resolve-collision))
(dir '()))
(match tree
((? string?)
diff --git a/tests/union.scm b/tests/union.scm
index 317d49dc35..a3859434a2 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -64,6 +64,25 @@
(bin make)
(share (doc (make README))))))
+(test-equal "delete-duplicate-leaves, default"
+ '(bin make touch ls)
+ (delete-duplicate-leaves '(bin ls make touch ls)))
+
+(test-equal "delete-duplicate-leaves, file names"
+ '("doc" ("info"
+ "/binutils/ld.info"
+ "/gcc/gcc.info"
+ "/binutils/standards.info"))
+ (let ((leaf=? (lambda (a b)
+ (string=? (basename a) (basename b)))))
+ (delete-duplicate-leaves '("doc"
+ ("info"
+ "/binutils/ld.info"
+ "/binutils/standards.info"
+ "/gcc/gcc.info"
+ "/gcc/standards.info"))
+ leaf=?)))
+
(test-skip (if (and %store
(false-if-exception
(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))