guix-package: Add `--list-installed'.

* guix-package.in (show-help, %options): Add `--list-installed'.
  (guix-package): Move main body to...
  [process-actions]: ... here.  New internal procedure.
  [process-query]: New procedure.
* tests/guix-package.sh: Add tests for `--list-installed'.
* doc/guix.texi (Invoking guix-package): Document it.

3 files changed, 127 insertions, 64 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 637265d873..a93510ee23 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -239,7 +239,25 @@ useful to distribution developers.
 
 @end table
 
+In addition to these actions @command{guix-package} supports the
+following options to query the current state of a profile, or the
+availability of packages:
 
+@table @option
+
+@item --list-installed[=@var{regexp}]
+@itemx -I [@var{regexp}]
+List currently installed packages in the specified profile.  When
+@var{regexp} is specified, list only installed packages whose name
+matches @var{regexp}.
+
+For each installed package, print the following items, separated by
+tabs: the package name, its version string, the part of the package that
+is installed (for instance, @code{out} for the default output,
+@code{include} for its headers, etc.), and the path of this package in
+the store.
+
+@end table
 
 
 
diff --git a/guix-package.in b/guix-package.in
index b8e9f35d68..ba07eb7c2e 100644
--- a/guix-package.in
+++ b/guix-package.in
@@ -202,6 +202,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   -b, --bootstrap        use the bootstrap Guile to build the profile"))
   (newline)
   (display (_ "
+  -I, --list-installed[=REGEXP]
+                         list installed packages matching REGEXP"))
+  (newline)
+  (display (_ "
   -h, --help             display this help and exit"))
   (display (_ "
   -V, --version          display version information and exit"))
@@ -234,7 +238,11 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
                   (alist-cons 'dry-run? #t result)))
         (option '(#\b "bootstrap") #f #f
                 (lambda (opt name arg result)
-                  (alist-cons 'bootstrap? #t result)))))
+                  (alist-cons 'bootstrap? #t result)))
+        (option '(#\I "list-installed") #f #t
+                (lambda (opt name arg result)
+                  (cons `(query list-installed ,(or arg ""))
+                        result)))))
 
 
 ;;;
@@ -302,6 +310,84 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
         (()
          (leave (_ "~a: package not found~%") request)))))
 
+  (define (process-actions opts)
+    ;; Process any install/remove/upgrade action from OPTS.
+    (let* ((dry-run? (assoc-ref opts 'dry-run?))
+           (profile  (assoc-ref opts 'profile))
+           (install  (filter-map (match-lambda
+                                  (('install . (? store-path?))
+                                   #f)
+                                  (('install . package)
+                                   (find-package package))
+                                  (_ #f))
+                                 opts))
+           (drv      (filter-map (match-lambda
+                                  ((name version sub-drv
+                                         (? package? package))
+                                   (package-derivation %store package))
+                                  (_ #f))
+                                 install))
+           (install* (append
+                      (filter-map (match-lambda
+                                   (('install . (? store-path? path))
+                                    `(,(store-path-package-name path)
+                                      #f #f ,path))
+                                   (_ #f))
+                                  opts)
+                      (map (lambda (tuple drv)
+                             (match tuple
+                               ((name version sub-drv _)
+                                (let ((output-path
+                                       (derivation-path->output-path
+                                        drv sub-drv)))
+                                  `(,name ,version ,sub-drv ,output-path)))))
+                           install drv)))
+           (remove   (filter-map (match-lambda
+                                  (('remove . package)
+                                   package)
+                                  (_ #f))
+                                 opts))
+           (packages (append install*
+                             (fold alist-delete
+                                   (manifest-packages
+                                    (profile-manifest profile))
+                                   remove))))
+
+      (show-what-to-build drv dry-run?)
+
+      (or dry-run?
+          (and (build-derivations %store drv)
+               (let* ((prof-drv (profile-derivation %store packages))
+                      (prof     (derivation-path->output-path prof-drv))
+                      (number   (latest-profile-number profile))
+                      (name     (format #f "~a/~a-~a-link"
+                                        (dirname profile)
+                                        (basename profile) (+ 1 number))))
+                 (and (build-derivations %store (list prof-drv))
+                      (begin
+                        (symlink prof name)
+                        (when (file-exists? profile)
+                          (delete-file profile))
+                        (symlink name profile))))))))
+
+  (define (process-query opts)
+    ;; Process any query specified by OPTS.  Return #t when a query was
+    ;; actually processed, #f otherwise.
+    (let ((profile  (assoc-ref opts 'profile)))
+      (match (assoc-ref opts 'query)
+        (('list-installed regexp)
+         (let* ((regexp    (and regexp (make-regexp regexp)))
+                (manifest  (profile-manifest profile))
+                (installed (manifest-packages manifest)))
+           (for-each (match-lambda
+                      ((name version output path)
+                       (when (or (not regexp)
+                                 (regexp-exec regexp name))
+                         (format #t "~a\t~a\t~a\t~a~%"
+                                 name (or version "?") output path))))
+                     installed)))
+        (_ #f))))
+
   (setlocale LC_ALL "")
   (textdomain "guix")
   (setvbuf (current-output-port) _IOLBF)
@@ -309,69 +395,14 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
 
   (let ((opts (parse-options)))
     (with-error-handling
-      (parameterize ((%guile-for-build
-                      (package-derivation %store
-                                          (if (assoc-ref opts 'bootstrap?)
-                                              (@@ (distro packages base)
-                                                  %bootstrap-guile)
-                                              guile-2.0))))
-        (let* ((dry-run? (assoc-ref opts 'dry-run?))
-               (profile  (assoc-ref opts 'profile))
-               (install  (filter-map (match-lambda
-                                      (('install . (? store-path?))
-                                       #f)
-                                      (('install . package)
-                                       (find-package package))
-                                      (_ #f))
-                                     opts))
-               (drv      (filter-map (match-lambda
-                                      ((name version sub-drv
-                                             (? package? package))
-                                       (package-derivation %store package))
-                                      (_ #f))
-                                     install))
-               (install* (append
-                          (filter-map (match-lambda
-                                       (('install . (? store-path? path))
-                                        `(,(store-path-package-name path)
-                                          #f #f ,path))
-                                       (_ #f))
-                                      opts)
-                          (map (lambda (tuple drv)
-                                 (match tuple
-                                   ((name version sub-drv _)
-                                    (let ((output-path
-                                           (derivation-path->output-path
-                                            drv sub-drv)))
-                                      `(,name ,version ,sub-drv ,output-path)))))
-                               install drv)))
-               (remove   (filter-map (match-lambda
-                                      (('remove . package)
-                                       package)
-                                      (_ #f))
-                                     opts))
-               (packages (append install*
-                                 (fold alist-delete
-                                       (manifest-packages
-                                        (profile-manifest profile))
-                                       remove))))
-
-          (show-what-to-build drv dry-run?)
-
-          (or dry-run?
-              (and (build-derivations %store drv)
-                   (let* ((prof-drv (profile-derivation %store packages))
-                          (prof     (derivation-path->output-path prof-drv))
-                          (number   (latest-profile-number profile))
-                          (name     (format #f "~a/~a-~a-link"
-                                            (dirname profile)
-                                            (basename profile) (+ 1 number))))
-                     (and (build-derivations %store (list prof-drv))
-                          (begin
-                            (symlink prof name)
-                            (when (file-exists? profile)
-                              (delete-file profile))
-                            (symlink name profile)))))))))))
+      (or (process-query opts)
+          (parameterize ((%guile-for-build
+                          (package-derivation %store
+                                              (if (assoc-ref opts 'bootstrap?)
+                                                  (@@ (distro packages base)
+                                                      %bootstrap-guile)
+                                                  guile-2.0))))
+            (process-actions opts))))))
 
 ;; Local Variables:
 ;; eval: (put 'guard 'scheme-indent-function 1)
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 7363cfc945..6c457ffd4b 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -36,6 +36,20 @@ guix-package -b -p "$profile"						\
 test -L "$profile-2-link"
 test -f "$profile/bin/make" && test -f "$profile/bin/guile"
 
+
+# Check whether `--list-installed' works.
+# XXX: Change the tests when `--install' properly extracts the package
+# name and version string.
+installed="`guix-package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`"
+case "x$installed" in
+    "guile* make*") true;;
+    "make* guile*") true;;
+    "*")            false;;
+esac
+
+test "`guix-package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap-2.0"
+
+# Remove a package.
 guix-package -b -p "$profile" -r "guile-bootstrap-2.0"
 test -L "$profile-3-link"
 test -f "$profile/bin/make" && ! test -f "$profile/bin/guile"