gnu: cuirass: Update to 1.0.0-11.922cc66.

[jackhill/guix/guix.git] / guix / utils.scm

diff --git a/guix/utils.scm b/guix/utils.scm
index a85e2f4..05af86f 100644 (file)
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -8,6 +8,8 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,12 +39,14 @@
   #:use-module (guix memoization)
   #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
   #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
+  #:use-module ((guix combinators) #:select (fold2))
   #:use-module (guix diagnostics)           ;<location>, &error-location, etc.
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module ((ice-9 iconv) #:prefix iconv:)
+  #:autoload   (zlib) (make-zlib-input-port make-zlib-output-port)
   #:use-module (system foreign)
   #:re-export (<location>                         ;for backwards compatibility
                location
@@ -76,6 +80,7 @@
             target-arm32?
             target-aarch64?
             target-arm?
+            target-powerpc?
             target-64bit?
             cc-for-target
             cxx-for-target
@@ -115,7 +120,10 @@
             call-with-decompressed-port
             compressed-output-port
             call-with-compressed-output-port
-            canonical-newline-port))
+            canonical-newline-port
+
+            string-distance
+            string-closest))
 
 \f
 ;;;
@@ -226,7 +234,8 @@ a symbol such as 'xz."
     ((or #f 'none) (values input '()))
     ('bzip2        (filtered-port `(,%bzip2 "-dc") input))
     ('xz           (filtered-port `(,%xz "-dc") input))
-    ('gzip         (filtered-port `(,%gzip "-dc") input))
+    ('gzip         (values (make-zlib-input-port input #:format 'gzip)
+                           '()))
     ('lzip         (values (lzip-port 'make-lzip-input-port input)
                            '()))
     ('zstd         (values (zstd-port 'make-zstd-input-port input)
@@ -287,7 +296,8 @@ program--e.g., '(\"--fast\")."
     ((or #f 'none) (values output '()))
     ('bzip2        (filtered-output-port `(,%bzip2 "-c" ,@options) output))
     ('xz           (filtered-output-port `(,%xz "-c" ,@options) output))
-    ('gzip         (filtered-output-port `(,%gzip "-c" ,@options) output))
+    ('gzip         (values (make-zlib-output-port output #:format 'gzip)
+                           '()))
     ('lzip         (values (lzip-port 'make-lzip-output-port output)
                            '()))
     ('zstd         (values (zstd-port 'make-zstd-output-port output)
@@ -533,9 +543,13 @@ a character other than '@'."
                                              (%current-system))))
   (or (target-arm32? target) (target-aarch64? target)))
 
+(define* (target-powerpc? #:optional (target (or (%current-target-system)
+                                                 (%current-system))))
+  (string-prefix? "powerpc" target))
+
 (define* (target-64bit? #:optional (system (or (%current-target-system)
                                                (%current-system))))
-  (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64")))
+  (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64")))
 
 (define* (cc-for-target #:optional (target (%current-target-system)))
   (if target
@@ -682,6 +696,7 @@ VERSIONS.  For example:
 (define (tarball-sans-extension tarball)
   "Return TARBALL without its .tar.* or .zip extension."
   (let ((end (or (string-contains tarball ".tar")
+                 (string-contains tarball ".tgz")
                  (string-contains tarball ".zip"))))
     (substring tarball 0 end)))
 
@@ -880,6 +895,46 @@ be determined."
           ;; raising an error would upset Geiser users
           #f))))))
 
+\f
+;;;
+;;; String comparison.
+;;;
+
+(define (string-distance s1 s2)
+  "Compute the Levenshtein distance between two strings."
+  ;; Naive implemenation
+  (define loop
+    (mlambda (as bt)
+      (match as
+        (() (length bt))
+        ((a s ...)
+         (match bt
+           (() (length as))
+           ((b t ...)
+            (if (char=? a b)
+                (loop s t)
+                (1+ (min
+                     (loop as t)
+                     (loop s bt)
+                     (loop s t))))))))))
+
+  (let ((c1 (string->list s1))
+        (c2 (string->list s2)))
+    (loop c1 c2)))
+
+(define* (string-closest trial tests #:key (threshold 3))
+  "Return the string from TESTS that is the closest from the TRIAL,
+according to 'string-distance'.  If the TESTS are too far from TRIAL,
+according to THRESHOLD, then #f is returned."
+  (identity                              ;discard second return value
+    (fold2 (lambda (test closest minimal)
+             (let ((dist (string-distance trial test)))
+               (if (and  (< dist minimal) (< dist threshold))
+                   (values test dist)
+                   (values closest minimal))))
+           #f +inf.0
+           tests)))
+
 ;;; Local Variables:
 ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
 ;;; End: