[PATCH 1/6] emacs: Add 'guix-packages-by-location' command.

[Alex Kost]

* emacs/guix-main.scm (%package-location-table): New variable.
(package-location-table, package-locations, packages-by-location): 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.
---
 doc/emacs.texi           |  3 +++
 emacs/guix-main.scm      | 38 ++++++++++++++++++++++++++++++++++++++
 emacs/guix-messages.el   | 15 +++++++++++++++
 emacs/guix-read.el       | 10 ++++++++++
 emacs/guix-ui-package.el | 12 +++++++++++-
 5 files changed, 77 insertions(+), 1 deletion(-)

diff --git a/doc/emacs.texi b/doc/emacs.texi
index c4fdfff..16ff4d5 100644
--- a/doc/emacs.texi
+++ b/doc/emacs.texi
@@ -160,6 +160,9 @@ Display package(s) with the specified name.
 @item M-x guix-packages-by-license
 Display package(s) with the specified license.
 
address@hidden M-x guix-packages-by-location
+Display package(s) placed in the specified location.
+
 @item M-x guix-search-by-regexp
 Search for packages by a specified regexp.  By default ``name'',
 ``synopsis'' and ``description'' of the packages will be searched.  This
diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm
index c620440..9950cad 100644
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -39,6 +39,9 @@
 ;;
 ;; - `%package-table' - Hash table of
 ;;   "name+version key"/"list of packages" pairs.
+;;
+;; - `%location-table' - Hash table of
+;;   "package location"/"list of packages" pairs.
 
 ;;; Code:
 
@@ -684,6 +687,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 location)))
          (all-proc              (lambda _ (all-available-packages)))
          (newest-proc           (lambda _ (newest-available-packages))))
     `((package
@@ -693,6 +698,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 +708,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 +1104,34 @@ 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 %package-location-table
+  (delay
+    (let ((table (make-hash-table
+                  ;; Rough guess about a number of locations: it is
+                  ;; about 10 times less than the number of packages.
+                  (euclidean/ (vlist-length (package-vhash)) 10))))
+      ;; XXX Actually, 'for-each-package' is needed but there is no such yet.
+      (fold-packages
+       (lambda (package _)
+         (let* ((location (location-file (package-location package)))
+                (packages (or (hash-ref table location) '())))
+           (hash-set! table location (cons package packages))))
+       #f)
+      table)))
+
+(define (package-location-table)
+  "Return hash table of 'location'/'list of packages' pairs."
+  (force %package-location-table))
+
+(define (package-locations)
+  "Return a list of available package locations."
+  (hash-map->list (lambda (location _) location)
+                  (package-location-table)))
+
+(define (packages-by-location location)
+  "Return a list of packages placed in LOCATION."
+  (hash-ref (package-location-table) location))
diff --git a/emacs/guix-messages.el b/emacs/guix-messages.el
index de0331f..7ebe7e8 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 a1a6b86..0551af9 100644
--- a/emacs/guix-read.el
+++ b/emacs/guix-read.el
@@ -62,6 +62,11 @@
   "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-locations))
+        #'string<))
+
 
 ;;; Readers
 
@@ -131,6 +136,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 df5f8d1..ecabae1 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 <address@hidden>
+;; Copyright © 2014, 2015, 2016 Alex Kost <address@hidden>
 
 ;; 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.
+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.
-- 
2.7.3