emacs: Add 'guix-packages-by-location' command.

* emacs/guix-main.scm (packages-by-location-file, package-location-files):
New procedures.
(%patterns-makers): Add 'location' search type.
* emacs/guix-messages.el (guix-message-packages-by-location): New procedure.
(guix-messages): Use it.
* emacs/guix-read.el (guix-package-locations)
(guix-read-package-location): New procedures.
* emacs/guix-ui-package.el (guix-packages-by-location): New command.
* doc/emacs.texi (Emacs Commands): Document it.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>

4 files changed, 67 insertions, 1 deletions

diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm
index c62044056f..4780cced96 100644
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -684,6 +684,8 @@ ENTRIES is a list of installed manifest entries."
          (license-proc          (lambda (_ license-name)
                                   (packages-by-license
                                    (lookup-license license-name))))
+         (location-proc         (lambda (_ location)
+                                  (packages-by-location-file location)))
          (all-proc              (lambda _ (all-available-packages)))
          (newest-proc           (lambda _ (newest-available-packages))))
     `((package
@@ -693,6 +695,7 @@ ENTRIES is a list of installed manifest entries."
        (obsolete         . ,(apply-to-first obsolete-package-patterns))
        (regexp           . ,regexp-proc)
        (license          . ,license-proc)
+       (location         . ,location-proc)
        (all-available    . ,all-proc)
        (newest-available . ,newest-proc))
       (output
@@ -702,6 +705,7 @@ ENTRIES is a list of installed manifest entries."
        (obsolete         . ,(apply-to-first obsolete-output-patterns))
        (regexp           . ,regexp-proc)
        (license          . ,license-proc)
+       (location         . ,location-proc)
        (all-available    . ,all-proc)
        (newest-available . ,newest-proc)))))
 
@@ -1097,3 +1101,29 @@ Return #t if the shell command was executed successfully."
 (define (license-entries search-type . search-values)
   (map license->sexp
        (apply find-licenses search-type search-values)))
+
+
+;;; Package locations
+
+(define-values (packages-by-location-file
+                package-location-files)
+  (let* ((table (delay (fold-packages
+                        (lambda (package table)
+                          (let ((file (location-file
+                                       (package-location package))))
+                            (vhash-cons file package table)))
+                        vlist-null)))
+         (files (delay (vhash-fold
+                        (lambda (file _ result)
+                          (if (member file result)
+                              result
+                              (cons file result)))
+                        '()
+                        (force table)))))
+    (values
+     (lambda (file)
+       "Return the (possibly empty) list of packages defined in location FILE."
+       (vhash-fold* cons '() file (force table)))
+     (lambda ()
+       "Return the list of file names of all package locations."
+       (force files)))))
diff --git a/emacs/guix-messages.el b/emacs/guix-messages.el
index de0331fff8..7ebe7e8b5c 100644
--- a/emacs/guix-messages.el
+++ b/emacs/guix-messages.el
@@ -40,6 +40,10 @@
       ,(lambda (_ entries licenses)
          (apply #'guix-message-packages-by-license
                 entries 'package licenses)))
+     (location
+      ,(lambda (_ entries locations)
+         (apply #'guix-message-packages-by-location
+                entries 'package locations)))
      (regexp
       (0 "No packages matching '%s'." val)
       (1 "A single package matching '%s'." val)
@@ -72,6 +76,10 @@
       ,(lambda (_ entries licenses)
          (apply #'guix-message-packages-by-license
                 entries 'output licenses)))
+     (location
+      ,(lambda (_ entries locations)
+         (apply #'guix-message-packages-by-location
+                entries 'output locations)))
      (regexp
       (0 "No package outputs matching '%s'." val)
       (1 "A single package output matching '%s'." val)
@@ -174,6 +182,13 @@ Try \"M-x guix-search-by-name\"."
          (str-end (format "with license '%s'" license)))
     (message "%s %s." str-beg str-end)))
 
+(defun guix-message-packages-by-location (entries entry-type location)
+  "Display a message for packages or outputs searched by LOCATION."
+  (let* ((count   (length entries))
+         (str-beg (guix-message-string-entries count entry-type))
+         (str-end (format "placed in '%s'" location)))
+    (message "%s %s." str-beg str-end)))
+
 (defun guix-message-generations-by-time (profile entries times)
   "Display a message for generations searched by TIMES."
   (let* ((count (length entries))
diff --git a/emacs/guix-read.el b/emacs/guix-read.el
index a1a6b86364..5423c9bcfa 100644
--- a/emacs/guix-read.el
+++ b/emacs/guix-read.el
@@ -62,6 +62,12 @@
   "Return a list of names of available licenses."
   (guix-eval-read (guix-make-guile-expression 'license-names)))
 
+(guix-memoized-defun guix-package-locations ()
+  "Return a list of available package locations."
+  (sort (guix-eval-read (guix-make-guile-expression
+                         'package-location-files))
+        #'string<))
+
 
 ;;; Readers
 
@@ -131,6 +137,11 @@
  :single-reader guix-read-license-name
  :single-prompt "License: ")
 
+(guix-define-readers
+ :completions-getter guix-package-locations
+ :single-reader guix-read-package-location
+ :single-prompt "Location: ")
+
 (provide 'guix-read)
 
 ;;; guix-read.el ends here
diff --git a/emacs/guix-ui-package.el b/emacs/guix-ui-package.el
index df5f8d12d1..07bbd973e7 100644
--- a/emacs/guix-ui-package.el
+++ b/emacs/guix-ui-package.el
@@ -1,6 +1,6 @@
 ;;; guix-ui-package.el --- Interface for displaying packages  -*- lexical-binding: t -*-
 
-;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
+;; Copyright © 2014, 2015, 2016 Alex Kost <alezost@gmail.com>
 
 ;; This file is part of GNU Guix.
 
@@ -970,6 +970,16 @@ Interactively with prefix, prompt for PROFILE."
   (guix-package-get-display profile 'license license))
 
 ;;;###autoload
+(defun guix-packages-by-location (location &optional profile)
+  "Display Guix packages placed in LOCATION file.
+If PROFILE is nil, use `guix-current-profile'.
+Interactively with prefix, prompt for PROFILE."
+  (interactive
+   (list (guix-read-package-location)
+         (guix-ui-read-profile)))
+  (guix-package-get-display profile 'location location))
+
+;;;###autoload
 (defun guix-search-by-regexp (regexp &optional params profile)
   "Search for Guix packages by REGEXP.
 PARAMS are package parameters that should be searched.