diff options
Diffstat (limited to 'guix/utils.scm')
| -rw-r--r-- | guix/utils.scm | 105 |
1 files changed, 90 insertions, 15 deletions
diff --git a/guix/utils.scm b/guix/utils.scm index 0df46f1062..1625cab19b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -8,6 +8,7 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +38,7 @@ #: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) @@ -88,6 +90,7 @@ version-major+minor+point version-major+minor version-major + version-unique-prefix guile-version>? version-prefix? string-replace-substring @@ -110,12 +113,14 @@ edit-expression filtered-port - compressed-port decompressed-port call-with-decompressed-port compressed-output-port call-with-compressed-output-port - canonical-newline-port)) + canonical-newline-port + + string-distance + string-closest)) ;;; @@ -211,7 +216,13 @@ buffered data is lost." "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. Raise an error if lzlib support is missing." (let ((make-port (module-ref (resolve-interface '(lzlib)) proc))) - (values (make-port port) '()))) + (make-port port))) + +(define (zstd-port proc port . args) + "Return the zstd port produced by calling PROC (a symbol) on PORT and ARGS. +Raise an error if zstd support is missing." + (let ((make-port (module-ref (resolve-interface '(zstd)) proc))) + (make-port port))) (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, @@ -223,17 +234,7 @@ a symbol such as 'xz." ('gzip (filtered-port `(,%gzip "-dc") input)) ('lzip (values (lzip-port 'make-lzip-input-port input) '())) - (_ (error "unsupported compression scheme" compression)))) - -(define (compressed-port compression input) - "Return an input port where INPUT is compressed according to COMPRESSION, -a symbol such as 'xz." - (match compression - ((or #f 'none) (values input '())) - ('bzip2 (filtered-port `(,%bzip2 "-c") input)) - ('xz (filtered-port `(,%xz "-c") input)) - ('gzip (filtered-port `(,%gzip "-c") input)) - ('lzip (values (lzip-port 'make-lzip-input-port/compressed input) + ('zstd (values (zstd-port 'make-zstd-input-port input) '())) (_ (error "unsupported compression scheme" compression)))) @@ -294,6 +295,8 @@ program--e.g., '(\"--fast\")." ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) ('lzip (values (lzip-port 'make-lzip-output-port output) '())) + ('zstd (values (zstd-port 'make-zstd-output-port output) + '())) (_ (error "unsupported compression scheme" compression)))) (define* (call-with-compressed-output-port compression port proc @@ -592,6 +595,38 @@ minor version numbers from version-string." "Return the major version number as string from the version-string." (version-prefix version-string 1)) +(define (version-unique-prefix version versions) + "Return the shortest version prefix to unambiguously identify VERSION among +VERSIONS. For example: + + (version-unique-prefix \"2.0\" '(\"3.0\" \"2.0\")) + => \"2\" + + (version-unique-prefix \"2.2\" '(\"3.0.5\" \"2.0.9\" \"2.2.7\")) + => \"2.2\" + + (version-unique-prefix \"27.1\" '(\"27.1\")) + => \"\" +" + (define not-dot + (char-set-complement (char-set #\.))) + + (define other-versions + (delete version versions)) + + (let loop ((prefix '()) + (components (string-tokenize version not-dot))) + (define prefix-str + (string-join prefix ".")) + + (if (any (cut string-prefix? prefix-str <>) other-versions) + (match components + ((head . tail) + (loop `(,@prefix ,head) tail)) + (() + version)) + prefix-str))) + (define (version>? a b) "Return #t when A denotes a version strictly newer than B." (eq? '> (version-compare a b))) @@ -850,6 +885,46 @@ be determined." ;; raising an error would upset Geiser users #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: |