[bug#50878] [PATCH 4/4] WIP guix: build: Add resolve-collision/alphanumeric-last for union.

[Attila Lendvai]

It is currently not used anywhere, only exported. The tests are boken, because
guile is too old in the test environment, at least on 'x86_64-linux' (guile
2.0.9 doesn't have srfi-43, aka vectors). Probably it's also broken because
testing errors with `no code for module (guix build utils)`.

* guix/build/union.scm (resolve-collision/alphanumeric-last): New function.
* guix/build/utils.scm (compare-strings-ignoring-store-path-prefix): New 
function.
---

I think the previous 3 patches in this patchset are worthy of inclusion,
but this one is more of a good idea than a worked out change, to be picked
up later, if at all.

The primary issue is that the test framework uses a guile that is too old,
but it's also not used anywhere. It would be nice if this was used for
resolving conflicts for profiles, i.e. for the user's bin/ directory.

 guix/build/union.scm | 12 ++++++++++++
 guix/build/utils.scm | 27 +++++++++++++++++++++++++++
 tests/union.scm      |  9 +++++++++
 3 files changed, 48 insertions(+)

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 9e8c2af4f5..339af7576c 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -19,15 +19,18 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build union)
+  #:use-module (guix build utils)
   #:use-module (ice-9 match)
   #: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
 
             default-collision-resolver
+            resolve-collision/alphanumeric-last
 
             relative-file-name
             symlink-relative))
@@ -102,6 +105,15 @@ identical, #f otherwise."
   ;; applications via 'glib-or-gtk-build-system'.
   '("icon-theme.cache" "gschemas.compiled"))
 
+(define (resolve-collision/alphanumeric-last files)
+  ;; Let's do a stable-sort, so that multiple foo-1.2.3/bin/foo variants will
+  ;; predictably resolve to the highest versioned one.
+  (let ((files-vector (list->vector files)))
+    (stable-sort! files-vector
+                  (lambda (a b)
+                    (> 0 (compare-strings-ignoring-store-path-prefix a b))))
+    (vector-ref files-vector 0)))
+
 (define (resolve-collision/pick-first files)
   (first files))
 
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 4009c137b8..1ae0244b04 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -47,6 +47,7 @@
             %store-hash-string-length
             store-file-name?
             strip-store-file-name
+            compare-strings-ignoring-store-path-prefix
             package-name->name+version
             parallel-job-count
 
@@ -171,6 +172,32 @@
 is typically a \"PACKAGE-VERSION\" string."
   (string-drop file (store-path-prefix-length)))
 
+(define (compare-strings-ignoring-store-path-prefix a b)
+  (let ((a-length (string-length a))
+        (b-length (string-length b)))
+    (do ((i (store-path-prefix-length) (+ i 1)))
+        ((not (and (< i a-length)
+                   (< i b-length)
+                   (char=? (string-ref a i)
+                           (string-ref b i))))
+         (cond
+          ((= a-length b-length)
+           (if (= i a-length)      ; we reached the end without any difference
+               0
+               (- (char->integer (string-ref a i))
+                  (char->integer (string-ref b i)))))
+          ((> a-length b-length)
+           (if (= i b-length)   ; we reached the end of B without a difference
+               1
+               (- (char->integer (string-ref a i))
+                  (char->integer (string-ref b i)))))
+          (else                 ; i.e. (< a-length b-length)
+           (if (= i a-length)   ; we reached the end of A without a difference
+               -1
+               (- (char->integer (string-ref a i))
+                  (char->integer (string-ref b i)))))))
+      '())))
+
 (define (package-name->name+version name)
   "Given NAME, a package name like \"foo-0.9.1b\", return two values:
 \"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
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