Toggle diff (134 lines)
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index ba2bc1573e..76b7c05072 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -104,7 +104,7 @@ (define-json-mapping <crate-dependency> make-crate-dependency
;; Autoload Guile-Semver so we only have a soft dependency.
(module-autoload! (current-module)
- '(semver) '(string->semver semver->string semver<? semver=?))
+ '(semver) '(string->semver semver->string semver<? semver=? semver>?))
(module-autoload! (current-module)
'(semver ranges) '(string->semver-range semver-range-contains?))
@@ -233,20 +233,32 @@ (define (string->license string)
'unknown-license!)))
(string-split string (string->char-set " /"))))
+(define (min-element l less)
+ "Returns the smallest element of l according to less or #f if l is empty."
+
+ (let loop ((curr #f)
+ (remaining l))
+ (if (null-list? remaining)
+ curr
+ (let ((next (car remaining))
+ (remaining (cdr remaining)))
+ (if (and curr
+ (not (less next curr)))
+ (loop curr remaining)
+ (loop next remaining))))))
+
(define (max-crate-version-of-semver semver-range range)
"Returns a <crate-version> of the highest version within the semver range."
- (let ((matching-crates
- (sort
- (filter (lambda (entry)
- (semver-range-contains?
- semver-range
- (string->semver (crate-version-number entry))))
- range)
- (lambda (entry1 entry2)
- (version>? (crate-version-number entry1)
- (crate-version-number entry2))))))
- (and (not (null-list? matching-crates))
- (first matching-crates))))
+
+ (define (crate->semver crate)
+ (string->semver (crate-version-number crate)))
+
+ (min-element
+ (filter (lambda (crate)
+ (semver-range-contains? semver-range (crate->semver crate)))
+ range)
+ (lambda args
+ (apply semver>? (map crate->semver args)))))
(define (nonyanked-crate-versions crate)
"Returns a list of <crate-version>s which are not yanked by upstream."
@@ -284,8 +296,8 @@ (define version-number
;; Packages previously marked as yanked take lower priority.
(define (find-package-version name range)
(let* ((semver-range (string->semver-range range))
- (package-versions
- (sort
+ (version
+ (min-element
(filter (match-lambda ((semver yanked)
(and
(or allow-yanked? (not yanked))
@@ -293,17 +305,17 @@ (define (find-package-version name range)
(map (lambda (pkg)
(let ((version (package-version pkg)))
(list
- (string->semver version)
- (assoc-ref (package-properties pkg)
- 'crate-version-yanked?))))
+ (string->semver version)
+ (assoc-ref (package-properties pkg)
+ 'crate-version-yanked?))))
(find-packages-by-name
(crate-name->package-name name))))
(match-lambda* (((semver1 yanked1) (semver2 yanked2))
- (or (and yanked1 (not yanked2))
- (and (eq? yanked1 yanked2)
- (semver<? semver1 semver2))))))))
- (and (not (null-list? package-versions))
- (match-let (((semver yanked) (last package-versions)))
+ (and (or (not yanked1) yanked2)
+ (or (not (eq? yanked1 yanked2))
+ (semver>? semver1 semver2))))))))
+ (and (not (eq? #f version))
+ (match-let (((semver yanked) version))
(list (semver->string semver) yanked)))))
;; Find the highest version of a crate that fulfills the semver <range>.
@@ -449,18 +461,22 @@ (define* (import-release package #:key (version #f))
"Return an <upstream-source> for the latest release of PACKAGE. Optionally
include a VERSION string to fetch a specific version."
(let* ((crate-name (guix-package->crate-name package))
- (crate (lookup-crate crate-name))
- (version (or version
- (crate-version-number
- (max-crate-version-of-semver
- (string->semver-range
- (string-append "^" (package-version package)))
- (nonyanked-crate-versions crate)))))
- (url (crate-uri crate-name version)))
- (upstream-source
- (package (package-name package))
- (version version)
- (urls (list url)))))
+ (crate (lookup-crate crate-name))
+ (version
+ (or version
+ (let ((max-crate-version
+ (max-crate-version-of-semver
+ (string->semver-range
+ (string-append "^" (package-version package)))
+ (nonyanked-crate-versions crate))))
+ (and max-crate-version
+ (crate-version-number max-crate-version))))))
+ (if version
+ (upstream-source
+ (package (package-name package))
+ (version version)
+ (urls (list (crate-uri crate-name version))))
+ #f)))
(define %crate-updater
(upstream-updater
Cheers,
David
