Merge branch 'master' into core-updates

1 files changed, 229 insertions, 30 deletions

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 333b18f9f0..9cd57fc704 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
@@ -28,11 +28,14 @@
   #:use-module (guix memoization)
   #:use-module ((guix build utils)
                 #:select ((package-name->name+version
-                           . hyphen-separated-name->name+version)))
+                           . hyphen-separated-name->name+version)
+                          mkdir-p))
   #:autoload   (guix profiles) (packages->manifest)
   #:use-module (guix describe)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
+  #:autoload   (ice-9 binary-ports) (put-bytevector)
+  #:autoload   (system base compile) (compile)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -50,14 +53,18 @@
             %default-package-module-path
 
             fold-packages
+            fold-available-packages
 
             find-packages-by-name
+            find-package-locations
             find-best-packages-by-name
-            find-newest-available-packages
 
             specification->package
             specification->package+output
-            specifications->manifest))
+            specification->location
+            specifications->manifest
+
+            generate-package-cache))
 
 ;;; Commentary:
 ;;;
@@ -140,6 +147,14 @@ for system '~a'")
   ;; Default search path for package modules.
   `((,%distro-root-directory . "gnu/packages")))
 
+(define (cache-is-authoritative?)
+  "Return true if the pre-computed package cache is authoritative.  It is not
+authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L'
+flags."
+  (equal? (%package-module-path)
+          (append %default-package-module-path
+                  (package-path-entries))))
+
 (define %package-module-path
   ;; Search path for package modules.  Each item must be either a directory
   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
@@ -172,6 +187,50 @@ for system '~a'")
               directory))
         %load-path)))
 
+(define (fold-available-packages proc init)
+  "Fold PROC over the list of available packages.  For each available package,
+PROC is called along these lines:
+
+  (PROC NAME VERSION RESULT
+        #:outputs OUTPUTS
+        #:location LOCATION
+        …)
+
+PROC can use #:allow-other-keys to ignore the bits it's not interested in.
+When a package cache is available, this procedure does not actually load any
+package module."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and cache (cache-is-authoritative?))
+      (vhash-fold (lambda (name vector result)
+                    (match vector
+                      (#(name version module symbol outputs
+                              supported? deprecated?
+                              file line column)
+                       (proc name version result
+                             #:outputs outputs
+                             #:location (and file
+                                             (location file line column))
+                             #:supported? supported?
+                             #:deprecated? deprecated?))))
+                  init
+                  cache)
+      (fold-packages (lambda (package result)
+                       (proc (package-name package)
+                             (package-version package)
+                             result
+                             #:outputs (package-outputs package)
+                             #:location (package-location package)
+                             #:supported?
+                             (->bool
+                              (member (%current-system)
+                                      (package-supported-systems package)))
+                             #:deprecated?
+                             (->bool
+                              (package-superseded package))))
+                     init)))
+
 (define* (fold-packages proc init
                         #:optional
                         (modules (all-modules (%package-module-path)
@@ -188,7 +247,35 @@ is guaranteed to never traverse the same package twice."
                                 init
                                 modules))
 
-(define find-packages-by-name
+(define %package-cache-file
+  ;; Location of the package cache.
+  "/lib/guix/package.cache")
+
+(define load-package-cache
+  (mlambda (profile)
+    "Attempt to load the package cache.  On success return a vhash keyed by
+package names.  Return #f on failure."
+    (match profile
+      (#f #f)
+      (profile
+       (catch 'system-error
+         (lambda ()
+           (define lst
+             (load-compiled (string-append profile %package-cache-file)))
+           (fold (lambda (item vhash)
+                   (match item
+                     (#(name version module symbol outputs
+                             supported? deprecated?
+                             file line column)
+                      (vhash-cons name item vhash))))
+                 vlist-null
+                 lst))
+         (lambda args
+           (if (= ENOENT (system-error-errno args))
+               #f
+               (apply throw args))))))))
+
+(define find-packages-by-name/direct              ;bypass the cache
   (let ((packages (delay
                     (fold-packages (lambda (p r)
                                      (vhash-cons (package-name p) p r))
@@ -207,28 +294,61 @@ decreasing version order."
                     matching)
             matching)))))
 
-(define find-newest-available-packages
-  (mlambda ()
-    "Return a vhash keyed by package names, and with
-associated values of the form
-
-  (newest-version newest-package ...)
-
-where the preferred package is listed first."
-
-    ;; FIXME: Currently, the preferred package is whichever one
-    ;; was found last by 'fold-packages'.  Find a better solution.
-    (fold-packages (lambda (p r)
-                     (let ((name    (package-name p))
-                           (version (package-version p)))
-                       (match (vhash-assoc name r)
-                         ((_ newest-so-far . pkgs)
-                          (case (version-compare version newest-so-far)
-                            ((>) (vhash-cons name `(,version ,p) r))
-                            ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
-                            ((<) r)))
-                         (#f (vhash-cons name `(,version ,p) r)))))
-                   vlist-null)))
+(define (cache-lookup cache name)
+  "Lookup package NAME in CACHE.  Return a list sorted in increasing version
+order."
+  (define (package-version<? v1 v2)
+    (version>? (vector-ref v2 1) (vector-ref v1 1)))
+
+  (sort (vhash-fold* cons '() name cache)
+        package-version<?))
+
+(define* (find-packages-by-name name #:optional version)
+  "Return the list of packages with the given NAME.  If VERSION is not #f,
+then only return packages whose version is prefixed by VERSION, sorted in
+decreasing version order."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and (cache-is-authoritative?) cache)
+      (match (cache-lookup cache name)
+        (#f #f)
+        ((#(_ versions modules symbols _ _ _ _ _ _) ...)
+         (fold (lambda (version* module symbol result)
+                 (if (or (not version)
+                         (version-prefix? version version*))
+                     (cons (module-ref (resolve-interface module)
+                                       symbol)
+                           result)
+                     result))
+               '()
+               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
@@ -236,9 +356,64 @@ version numbers; otherwise, return the list of packages named NAME and at
 VERSION."
   (if version
       (find-packages-by-name name version)
-      (match (vhash-assoc name (find-newest-available-packages))
-        ((_ version pkgs ...) pkgs)
-        (#f '()))))
+      (match (find-packages-by-name name)
+        (()
+         '())
+        ((matches ...)
+         ;; Return the subset of MATCHES with the higher version number.
+         (let ((highest (package-version (first matches))))
+           (take-while (lambda (p)
+                         (string=? (package-version p) highest))
+                       matches))))))
+
+(define (generate-package-cache directory)
+  "Generate under DIRECTORY a cache of all the available packages.
+
+The primary purpose of the cache is to speed up package lookup by name such
+that we don't have to traverse and load all the package modules, thereby also
+reducing the memory footprint."
+  (define cache-file
+    (string-append directory %package-cache-file))
+
+  (define (expand-cache module symbol variable result)
+    (match (false-if-exception (variable-ref variable))
+      ((? package? package)
+       (if (hidden-package? package)
+           result
+           (cons `#(,(package-name package)
+                    ,(package-version package)
+                    ,(module-name module)
+                    ,symbol
+                    ,(package-outputs package)
+                    ,(->bool (member (%current-system)
+                                     (package-supported-systems package)))
+                    ,(->bool (package-superseded package))
+                    ,@(let ((loc (package-location package)))
+                        (if loc
+                            `(,(location-file loc)
+                              ,(location-line loc)
+                              ,(location-column loc))
+                            '(#f #f #f))))
+                 result)))
+      (_
+       result)))
+
+  (define exp
+    (fold-module-public-variables* expand-cache '()
+                                   (all-modules (%package-module-path)
+                                                #:warn
+                                                warn-about-load-error)))
+
+  (mkdir-p (dirname cache-file))
+  (call-with-output-file cache-file
+    (lambda (port)
+      ;; Store the cache as a '.go' file.  This makes loading fast and reduces
+      ;; heap usage since some of the static data is directly mmapped.
+      (put-bytevector port
+                      (compile `'(,@exp)
+                               #:to 'bytecode
+                               #:opts '(#:to-file? #t)))))
+  cache-file)
 
 
 (define %sigint-prompt
@@ -294,6 +469,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 \"guile@2\" 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 ~a@~a 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: