08/10: edit: Use 'specification->location' to read information from the cache.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ee8099f5b688ce5f57790db4122f0b5b91a26216
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 13 14:27:10 2019 +0100

    edit: Use 'specification->location' to read information from the cache.
    
    That way 'guix edit' doesn't need to load any package module.
    
    * gnu/packages.scm (find-package-locations, specification->location):
    New procedures.
    * guix/scripts/edit.scm (package->location-specification): Rename to...
    (location->location-specification): ... this.  Expect a location object
    instead of a package.
    (guix-edit): Use 'specification->location' instead of
    'specification->package'.
    * tests/packages.scm ("find-package-locations")
    ("find-package-locations with cache")
    ("specification->location"): New tests.
---
 gnu/packages.scm      | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 guix/scripts/edit.scm | 29 +++++++++++------------------
 tests/packages.scm    | 23 +++++++++++++++++++++++
 3 files changed, 85 insertions(+), 18 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 6796db8..cf655e7 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -55,10 +55,12 @@
             fold-packages
 
             find-packages-by-name
+            find-package-locations
             find-best-packages-by-name
 
             specification->package
             specification->package+output
+            specification->location
             specifications->manifest
 
             generate-package-cache))
@@ -274,6 +276,31 @@ decreasing version order."
                versions modules symbols)))
       (find-packages-by-name/direct name version)))
 
+(define* (find-package-locations name #:optional version)
+  "Return a list of version/location pairs corresponding to each package
+matching NAME and VERSION."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and cache (cache-is-authoritative?))
+      (match (cache-lookup cache name)
+        (#f '())
+        ((#(name versions modules symbols outputs
+                 supported? deprecated?
+                 files lines columns) ...)
+         (fold (lambda (version* file line column result)
+                 (if (and file
+                          (or (not version)
+                              (version-prefix? version version*)))
+                     (alist-cons version* (location file line column)
+                                 result)
+                     result))
+               '()
+               versions files lines columns)))
+      (map (lambda (package)
+             (cons (package-version package) (package-location package)))
+           (find-packages-by-name/direct name version))))
+
 (define (find-best-packages-by-name name version)
   "If version is #f, return the list of packages named NAME with the highest
 version numbers; otherwise, return the list of packages named NAME and at
@@ -393,6 +420,30 @@ present, return the preferred newest version."
   (let-values (((name version) (package-name->name+version spec)))
     (%find-package spec name version)))
 
+(define (specification->location spec)
+  "Return the location of the highest-numbered package matching SPEC, a
+specification such as \"address@hidden" or \"emacs\"."
+  (let-values (((name version) (package-name->name+version spec)))
+    (match (find-package-locations name version)
+      (()
+       (if version
+           (leave (G_ "~A: package not found for version ~a~%") name version)
+           (leave (G_ "~A: unknown package~%") name)))
+      (lst
+       (let* ((highest   (match lst (((version . _) _ ...) version)))
+              (locations (take-while (match-lambda
+                                       ((version . location)
+                                        (string=? version highest)))
+                                     lst)))
+         (match locations
+           (((version . location) . rest)
+            (unless (null? rest)
+              (warning (G_ "ambiguous package specification `~a'~%") spec)
+              (warning (G_ "choosing address@hidden from ~a~%")
+                       name version
+                       (location->string location)))
+            location)))))))
+
 (define* (specification->package+output spec #:optional (output "out"))
   "Return the package and output specified by SPEC, or #f and #f; SPEC may
 optionally contain a version number and an output name, as in these examples:
diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm
index 8b2b61d..da3d277 100644
--- a/guix/scripts/edit.scm
+++ b/guix/scripts/edit.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Mathieu Lirzin <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,7 +21,6 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix utils)
-  #:use-module (guix packages)
   #:use-module (gnu packages)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
@@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of 
PACKAGE...\n"))
              file path))
     absolute-file-name))
 
-(define (package->location-specification package)
-  "Return the location specification for PACKAGE for a typical editor command
+(define (location->location-specification location)
+  "Return the location specification for LOCATION for a typical editor command
 line."
-  (let ((loc (package-location package)))
-    (list (string-append "+"
-                         (number->string
-                          (location-line loc)))
-          (search-path* %load-path (location-file loc)))))
+  (list (string-append "+"
+                       (number->string
+                        (location-line location)))
+        (search-path* %load-path (location-file location))))
 
 
 (define (guix-edit . args)
@@ -83,18 +81,13 @@ line."
                 '()))
 
   (with-error-handling
-    (let* ((specs    (reverse (parse-arguments)))
-           (packages (map specification->package specs)))
-      (for-each (lambda (package)
-                  (unless (package-location package)
-                    (leave (G_ "source location of package '~a' is unknown~%")
-                           (package-full-name package))))
-                packages)
+    (let* ((specs     (reverse (parse-arguments)))
+           (locations (map specification->location specs)))
 
       (catch 'system-error
         (lambda ()
-          (let ((file-names (append-map package->location-specification
-                                        packages)))
+          (let ((file-names (append-map location->location-specification
+                                        locations)))
             ;; Use `system' instead of `exec' in order to sanely handle
             ;; possible command line arguments in %EDITOR.
             (exit (system (string-join (cons (%editor) file-names))))))
diff --git a/tests/packages.scm b/tests/packages.scm
index 2720ba5..8aa117a 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1131,6 +1131,29 @@
     (lambda (key . args)
       key)))
 
+(test-equal "find-package-locations"
+  (map (lambda (package)
+         (cons (package-version package)
+               (package-location package)))
+       (find-packages-by-name "guile"))
+  (find-package-locations "guile"))
+
+(test-equal "find-package-locations with cache"
+  (map (lambda (package)
+         (cons (package-version package)
+               (package-location package)))
+       (find-packages-by-name "guile"))
+  (call-with-temporary-directory
+   (lambda (cache)
+     (generate-package-cache cache)
+     (mock ((guix describe) current-profile (const cache))
+           (mock ((gnu packages) cache-is-authoritative? (const #t))
+                 (find-package-locations "guile"))))))
+
+(test-equal "specification->location"
+  (package-location (specification->package "address@hidden"))
+  (specification->location "address@hidden"))
+
 (test-end "packages")
 
 ;;; Local Variables: