all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* [bug#50878] [PATCH] union: Resolve collisions by stable-sort'ing them.
@ 2021-09-28 21:40 Attila Lendvai
  2021-09-29 13:48 ` Maxime Devos
                   ` (3 more replies)
  0 siblings, 4 replies; 18+ messages in thread
From: Attila Lendvai @ 2021-09-28 21:40 UTC (permalink / raw)
  To: 50878; +Cc: Attila Lendvai

* guix/build/union.scm (resolve-collision/alphanumeric-last): New function.
(warn-about-collision): Renamed to default-collision-resolver.
---

this should work, but i cannot test it, because srfi-43 seems not to be
available on the build side:

unpacking bootstrap Guile to '/home/alendvai/workspace/guix/guix/test-tmp/store/qky0jf68rr7pnsvmhj0ay42rzh4qk6r9-guile-bootstrap-2.0'...
[...] output without sfri-43.go

and then unsurprisingly: "no code for module (srfi srfi-43)"

is tis only a peculiarity of the test environment?

can you please advise how to proceed?

 guix/build/union.scm | 26 ++++++++++++++++++++------
 guix/gexp.scm        |  2 +-
 tests/union.scm      |  9 +++++++++
 3 files changed, 30 insertions(+), 7 deletions(-)

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 961ac3298b..747902ec6c 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -23,11 +23,12 @@
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-43)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:export (union-build
 
-            warn-about-collision
+            default-collision-resolver
 
             relative-file-name
             symlink-relative))
@@ -102,10 +103,23 @@ identical, #f otherwise."
   ;; 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."
-  (let ((file (first files)))
+(define (resolve-collision/alphanumeric-last files)
+  ;; Let's do a stable-sort at least, so that multiple foo-1.2.3/bin/foo
+  ;; variants will predictably resolve to the highest versioned one.
+  (let* ((original-files (list->vector files))
+         (count (vector-length original-files))
+         (stripped-files (vector-map (lambda (_ el)
+                                       (strip-store-file-name el))
+                                     original-files))
+         (indices (vector-unfold values count)))
+    (stable-sort! indices
+                  (lambda (a b)
+                    (string> (vector-ref stripped-files a)
+                             (vector-ref stripped-files b))))
+    (vector-ref original-files (vector-ref indices 0))))
+
+(define (default-collision-resolver files)
+  (let ((file (resolve-collision/alphanumeric-last files)))
     (unless (member (basename file) %harmless-collisions)
       (format (current-error-port)
               "~%warning: collision encountered:~%~{  ~a~%~}"
@@ -117,7 +131,7 @@ first one of THEM."
                       #:key (log-port (current-error-port))
                       (create-all-directories? #f)
                       (symlink symlink)
-                      (resolve-collision warn-about-collision))
+                      (resolve-collision default-collision-resolver))
   "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 f3d278b3e6..32e8748443 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1983,7 +1983,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 'default-collision-resolver))
   "Return a directory that is the union of THINGS, where THINGS is a list of
 file-like objects denoting directories.  For example:
 
diff --git a/tests/union.scm b/tests/union.scm
index a8387edf42..cbf8840793 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -204,4 +204,13 @@
    ("/a/b" "/a/b/c/d"   => "c/d")
    ("/a/b/c" "/a/d/e/f" => "../../d/e/f")))
 
+(test-assert "resolve-collision/alphanumeric-last sorts alphanumerically"
+  (string=
+   ((@@ (guix build union) resolve-collision/alphanumeric-last)
+     (list "/gnu/store/c0000000000000000000000000000000-idris-0.0.0/bin/idris"
+           "/gnu/store/60000000000000000000000000000000-idris-2.0.0/bin/idris"
+           "/gnu/store/z0000000000000000000000000000000-idris-1.3.5/bin/idris"
+           "/gnu/store/00000000000000000000000000000000-idris-1.3.3/bin/idris"))
+   "/gnu/store/60000000000000000000000000000000-idris-2.0.0/bin/idris"))
+
 (test-end)
-- 
2.33.0





^ permalink raw reply related	[flat|nested] 18+ messages in thread

end of thread, other threads:[~2022-09-02 16:20 UTC | newest]

Thread overview: 18+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2021-09-28 21:40 [bug#50878] [PATCH] union: Resolve collisions by stable-sort'ing them Attila Lendvai
2021-09-29 13:48 ` Maxime Devos
2021-09-29 16:03   ` Attila Lendvai
2021-09-29 21:00     ` Maxime Devos
2021-09-29 17:42 ` Liliana Marie Prikler
2021-09-30  8:10   ` Attila Lendvai
2021-09-30  8:42     ` Maxime Devos
2021-09-30 14:00       ` Ludovic Courtès
2021-09-30 14:12       ` Attila Lendvai
2021-09-30 15:18         ` Maxime Devos
2021-09-30 18:13       ` Liliana Marie Prikler
2021-09-30 18:52     ` Liliana Marie Prikler
2021-10-03 12:43 ` [bug#50878] [PATCH 1/4] guix: build: Promote local define-inline to a define-constant util Attila Lendvai
2021-10-03 12:43   ` [bug#50878] [PATCH 2/4] guix: build: Avoid using magic literals in the code for hash length Attila Lendvai
2021-10-03 12:43   ` [bug#50878] [PATCH 3/4] guix: build: Factor out and export default-collision-resolver Attila Lendvai
2021-10-03 12:43   ` [bug#50878] [PATCH 4/4] WIP guix: build: Add resolve-collision/alphanumeric-last for union Attila Lendvai
2021-10-03 12:59 ` [bug#50878] (No Subject) Attila Lendvai
2022-09-02 16:04   ` Liliana Marie Prikler

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.