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

[Martin Becze]

* gnu/packages.scm (find-packages-by-naem*/direct)
---
 gnu/packages.scm   | 41 +++++++++++++++++++++++++++++++++++++++++
 tests/packages.scm | 13 +++++++++++++
 2 files changed, 54 insertions(+)

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 <address@hidden>
 ;;; Copyright © 2016, 2017 Alex Kost <address@hidden>
 ;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
+;;; Copyright © 2019 Martin Becze <address@hidden>
 ;;;
 ;;; 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 
<address@hidden>
 ;;; Copyright © Jan (janneke) Nieuwenhuizen <address@hidden>
+;;; Copyright © 2019 Martin Becze <address@hidden>
 ;;;
 ;;; 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
-- 
2.24.0