03/03: emacs: Add 'guix-package-from-file' command.

[Alex Kost]

alezost pushed a commit to branch master
in repository guix.

commit f8476e17a70ecc7d46c746480130477b7c35306b
Author: Alex Kost <address@hidden>
Date:   Tue Apr 5 23:39:03 2016 +0300

    emacs: Add 'guix-package-from-file' command.
    
    * emacs/guix-main.scm (register-package, packages-from-file): New 
procedures.
    (%patterns-makers): Add 'from-file' search type.
    * emacs/guix-messages.el (guix-messages): Add messages for it.
    * emacs/guix-ui-package.el (guix-package-from-file): New command.
    (guix-package-info-insert-location): Adjust for 'from-file' type.
    * doc/emacs.texi (Emacs Commands): Document it.
---
 doc/emacs.texi           |    5 +++++
 emacs/guix-main.scm      |   34 ++++++++++++++++++++++++++++------
 emacs/guix-messages.el   |    7 +++++++
 emacs/guix-ui-package.el |   33 ++++++++++++++++++++++++---------
 4 files changed, 64 insertions(+), 15 deletions(-)

diff --git a/doc/emacs.texi b/doc/emacs.texi
index 575e87c..d124eca 100644
--- a/doc/emacs.texi
+++ b/doc/emacs.texi
@@ -166,6 +166,11 @@ Display package(s) located in the specified file.  These 
files usually
 have the following form: @file{gnu/packages/emacs.scm}, but don't type
 them manually!  Press @key{TAB} to complete the file name.
 
address@hidden M-x guix-package-from-file
+Display package that the code within the specified file evaluates to.
address@hidden guix package, @code{--install-from-file}}, for an example
+of what such a file may look like.
+
 @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 5d7df2a..e645a85 100644
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -300,17 +300,26 @@ Example:
 
 ;;; Finding packages.
 
-(define package-by-address
+(define-values (package-by-address
+                register-package)
   (let ((table (delay (fold-packages
                        (lambda (package table)
                          (vhash-consq (object-address package)
                                       package table))
                        vlist-null))))
-    (lambda (address)
-      "Return package by its object ADDRESS."
-      (match (vhash-assq address (force table))
-        ((_ . package) package)
-        (_ #f)))))
+    (values
+     (lambda (address)
+       "Return package by its object ADDRESS."
+       (match (vhash-assq address (force table))
+         ((_ . package) package)
+         (_ #f)))
+     (lambda (package)
+       "Register PACKAGE by its 'object-address', so that later
+'package-by-address' can be used to access it."
+       (let ((table* (force table)))
+         (set! table
+               (delay (vhash-consq (object-address package)
+                                   package table*))))))))
 
 (define packages-by-name+version
   (let ((table (delay (fold-packages
@@ -410,6 +419,15 @@ MATCH-PARAMS is a list of parameters that REGEXP can 
match."
               '()
               (find-newest-available-packages)))
 
+(define (packages-from-file file)
+  "Return a list of packages from FILE."
+  (let ((package (load (canonicalize-path file))))
+    (if (package? package)
+        (begin
+          (register-package package)
+          (list package))
+        '())))
+
 
 ;;; Making package/output patterns.
 
@@ -662,6 +680,8 @@ ENTRIES is a list of installed manifest entries."
                                    (lookup-license license-name))))
          (location-proc         (lambda (_ location)
                                   (packages-by-location-file location)))
+         (file-proc             (lambda (_ file)
+                                  (packages-from-file file)))
          (all-proc              (lambda _ (all-available-packages)))
          (newest-proc           (lambda _ (newest-available-packages))))
     `((package
@@ -672,6 +692,7 @@ ENTRIES is a list of installed manifest entries."
        (regexp           . ,regexp-proc)
        (license          . ,license-proc)
        (location         . ,location-proc)
+       (from-file        . ,file-proc)
        (all-available    . ,all-proc)
        (newest-available . ,newest-proc))
       (output
@@ -682,6 +703,7 @@ ENTRIES is a list of installed manifest entries."
        (regexp           . ,regexp-proc)
        (license          . ,license-proc)
        (location         . ,location-proc)
+       (from-file        . ,file-proc)
        (all-available    . ,all-proc)
        (newest-available . ,newest-proc)))))
 
diff --git a/emacs/guix-messages.el b/emacs/guix-messages.el
index 7ebe7e8..52436af 100644
--- a/emacs/guix-messages.el
+++ b/emacs/guix-messages.el
@@ -44,6 +44,9 @@
       ,(lambda (_ entries locations)
          (apply #'guix-message-packages-by-location
                 entries 'package locations)))
+     (from-file
+      (0 "No package in file '%s'." val)
+      (1 "Package from file '%s'." val))
      (regexp
       (0 "No packages matching '%s'." val)
       (1 "A single package matching '%s'." val)
@@ -80,6 +83,10 @@
       ,(lambda (_ entries locations)
          (apply #'guix-message-packages-by-location
                 entries 'output locations)))
+     (from-file
+      (0 "No package in file '%s'." val)
+      (1 "Package from file '%s'." val)
+      (many "Package outputs from file '%s'." val))
      (regexp
       (0 "No package outputs matching '%s'." val)
       (1 "A single package output matching '%s'." val)
diff --git a/emacs/guix-ui-package.el b/emacs/guix-ui-package.el
index 38f0c08..edc3648 100644
--- a/emacs/guix-ui-package.el
+++ b/emacs/guix-ui-package.el
@@ -393,15 +393,17 @@ formatted with this string, an action button is 
inserted.")
       (guix-format-insert nil)
     (let ((location-file (car (split-string location ":"))))
       (guix-info-insert-value-indent location 'guix-package-location)
-      (guix-info-insert-indent)
-      (guix-info-insert-action-button
-       "Packages"
-       (lambda (btn)
-         (guix-package-get-display (guix-ui-current-profile)
-                                   'location
-                                   (button-get btn 'location)))
-       (format "Display packages from location '%s'" location-file)
-       'location location-file))))
+      ;; Do not show "Packages" button if a package 'from file' is displayed.
+      (unless (eq (guix-ui-current-search-type) 'from-file)
+        (guix-info-insert-indent)
+        (guix-info-insert-action-button
+         "Packages"
+         (lambda (btn)
+           (guix-package-get-display (guix-ui-current-profile)
+                                     'location
+                                     (button-get btn 'location)))
+         (format "Display packages from location '%s'" location-file)
+         'location location-file)))))
 
 (defun guix-package-info-insert-systems (systems entry)
   "Insert supported package SYSTEMS at point."
@@ -1001,6 +1003,19 @@ Interactively with prefix, prompt for PROFILE."
   (guix-package-get-display profile 'location location))
 
 ;;;###autoload
+(defun guix-package-from-file (file &optional profile)
+  "Display Guix package that the code from FILE evaluates to.
+If PROFILE is nil, use `guix-current-profile'.
+Interactively with prefix, prompt for PROFILE."
+  (interactive
+   (list (read-file-name "File with package: ")
+         (guix-ui-read-profile)))
+  (guix-buffer-get-display-entries
+   'info 'package
+   (list (or profile guix-current-profile) 'from-file file)
+   'add))
+
+;;;###autoload
 (defun guix-search-by-regexp (regexp &optional params profile)
   "Search for Guix packages by REGEXP.
 PARAMS are package parameters that should be searched.