diff mbox series

[bug#38408,v2,1/5] gnu: added new function, find-packages-by-name*/direct

Message ID dbe5240d37d3b42a6c1db1dfc07436bff5ed2297.1575575779.git.mjbecze@riseup.net
State Accepted
Headers show
Series Semantic version aware recusive importer for crates | expand

Commit Message

Martin Becze Dec. 5, 2019, 8:05 p.m. UTC 
* gnu/packages.scm (find-packages-by-naem*/direct)
---
 gnu/packages.scm   | 41 +++++++++++++++++++++++++++++++++++++++++
 tests/packages.scm | 13 +++++++++++++
 2 files changed, 54 insertions(+)
diff mbox series

Patch

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 959777ff8f..cca2a393e5 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -4,6 +4,7 @@ 
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,7 +53,9 @@ 
             %default-package-module-path
 
             fold-packages
+            fold-packages*
             fold-available-packages
+            find-packages-by-name*/direct
 
             find-newest-available-packages
             find-packages-by-name
@@ -250,6 +253,23 @@  is guaranteed to never traverse the same package twice."
                                 init
                                 modules))
 
+(define* (fold-packages* proc init
+                        #:optional
+                        (modules (all-modules (%package-module-path)
+                                              #:warn
+                                              warn-about-load-error))
+                        #:key (select? (negate hidden-package?)))
+  "Call (PROC PACKAGE RESULT) for each available package defined in one of
+MODULES that matches SELECT?, using INIT as the initial value of RESULT.  It
+is guaranteed to never traverse the same package twice."
+  (fold-module-public-variables* (lambda (module symbol var result)
+                                   (let ((object (variable-ref var)))
+                                     (if (and (package? object) (select? object))
+                                         (proc module symbol object  result)
+                                         result)))
+                                init
+                                modules))
+
 (define %package-cache-file
   ;; Location of the package cache.
   "/lib/guix/package.cache")
@@ -297,6 +317,27 @@  decreasing version order."
                     matching)
             matching)))))
 
+(define find-packages-by-name*/direct              ;bypass the cache
+  (let ((packages (delay
+                    (fold-packages* (lambda (mod sym p r)
+                                     (vhash-cons (package-name p) (list mod sym p) r))
+                                    vlist-null)))
+        (version>? (match-lambda*
+                     (((_ _ versions) ..1)
+                      (apply version>? (map package-version versions))))))
+    (lambda* (name #:optional version)
+      "Return the list of (<module> <symbol> <package>) with the given NAME.  If
+ VERSION is not #f, then only return packages whose version is prefixed by
+ VERSION, sorted in decreasing version order."
+      (let ((matching (sort (vhash-fold* cons '() name (force packages))
+                            version>?)))
+        (if version
+            (filter (match-lambda
+                      ((_ _ package)
+                       (version-prefix? version (package-version package))))
+                    matching)
+            matching)))))
+
 (define (cache-lookup cache name)
   "Lookup package NAME in CACHE.  Return a list sorted in increasing version
 order."
diff --git a/tests/packages.scm b/tests/packages.scm
index 423c5061aa..9f02b0d5d2 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,6 +1,7 @@ 
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1135,11 +1136,23 @@ 
     (((? (cut eq? hello <>))) #t)
     (wrong (pk 'find-packages-by-name wrong #f))))
 
+(test-assert "find-packages-by-name*/direct"
+  (match (find-packages-by-name*/direct "hello")
+    ((((? (cut eq? (resolve-interface '(gnu packages base)) <>))
+       (? (cut eq? 'hello <>))
+       (? (cut eq? hello <>)))) #t)))
+
 (test-assert "find-packages-by-name with version"
   (match (find-packages-by-name "hello" (package-version hello))
     (((? (cut eq? hello <>))) #t)
     (wrong (pk 'find-packages-by-name wrong #f))))
 
+(test-assert "find-packages-by-name*/direct with version"
+  (match (find-packages-by-name*/direct "hello" (package-version hello))
+    ((((? (cut eq? (resolve-interface '(gnu packages base)) <>))
+       (? (cut eq? 'hello <>))
+       (? (cut eq? hello <>)))) #t)))
+
 (test-equal "find-packages-by-name with cache"
   (find-packages-by-name "guile")
   (call-with-temporary-directory