[bug#56428] [PATCH v3] home: Add -I, --list-installed option.

[Antero Mejr via Guix-patches via <guix-patches@gnu.org>]

* guix/scripts/package.scm (list-installed): New procedure.
* guix/scripts/home.scm: Use it.
* guix/scripts/utils.scm (pretty-print-table): New argument "left-pad".
* doc/guix.texi (Invoking Guix Home): Add information and example for
--list-installed flag.
---
 doc/guix.texi            | 15 ++++++++++++
 guix/scripts/home.scm    | 52 +++++++++++++++++++++++++++++-----------
 guix/scripts/package.scm | 31 ++++++++++++++----------
 guix/utils.scm           |  4 ++--
 4 files changed, 73 insertions(+), 29 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 097e4a362b..fc3a2d962d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40312,6 +40312,17 @@ install anything.
 Describe the current home generation: its file name, as well as
 provenance information when available.
 
+To show installed packages in the current home generation's profile,
+the @code{--list-installed} flag is provided, with the same syntax that
+is used in @command{guix package --list-installed}
+(@pxref{Invoking guix package}). For instance, the following command
+shows a table of all emacs-related packages installed in the
+current home generation's profile, at the end of the description:
+
+@example
+guix home describe --list-installed=emacs
+@end example
+
 @item list-generations
 List a summary of each generation of the home environment available on
 disk, in a human-readable way.  This is similar to the
@@ -40327,6 +40338,10 @@ generations that are up to 10 days old:
 $ guix home list-generations 10d
 @end example
 
+The @code{--list-installed} flag may also be specified, with the same
+syntax that is used in @command{guix home describe}. This may be helpful
+if trying to determine when a package was added to the home profile.
+
 @item import
 Generate a @dfn{home environment} from the packages in the default
 profile and configuration files found in the user's home directory.  The
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 0f5c3388a1..97d626114a 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com>
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -143,6 +144,11 @@ (define (show-help)
                          use BACKEND for 'extension-graph' and 'shepherd-graph'"))
   (newline)
   (display (G_ "
+  -I, --list-installed[=REGEXP]
+                         for 'describe' or 'list-generations', list installed
+                         packages matching REGEXP"))
+  (newline)
+  (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
   -V, --version          display version information and exit"))
@@ -183,6 +189,9 @@ (define %options
          (option '("graph-backend") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'graph-backend arg result)))
+         (option '(#\I "list-installed") #f #t
+                 (lambda (opt name arg result)
+                   (alist-cons 'list-installed (or arg "") result)))
 
          ;; Container options.
          (option '(#\N "network") #f #f
@@ -569,17 +578,20 @@ (define-syntax-rule (with-store* store exp ...)
 deploy the home environment described by these files.\n")
                              destination))))
     ((describe)
-     (match (generation-number %guix-home)
-       (0
-        (leave (G_ "no home environment generation, nothing to describe~%")))
-       (generation
-        (display-home-environment-generation generation))))
+     (let ((list-installed-regex (assoc-ref opts 'list-installed)))
+       (match (generation-number %guix-home)
+         (0
+          (leave (G_ "no home environment generation, nothing to describe~%")))
+         (generation
+          (display-home-environment-generation
+           generation #:list-installed-regex list-installed-regex)))))
     ((list-generations)
-     (let ((pattern (match args
+     (let ((list-installed-regex (assoc-ref opts 'list-installed))
+           (pattern (match args
                       (() #f)
                       ((pattern) pattern)
                       (x (leave (G_ "wrong number of arguments~%"))))))
-       (list-generations pattern)))
+       (list-generations pattern #:list-installed-regex list-installed-regex)))
     ((switch-generation)
      (let ((pattern (match args
                       ((pattern) pattern)
@@ -748,7 +760,8 @@ (define (search . args)
 
 (define* (display-home-environment-generation
           number
-          #:optional (profile %guix-home))
+          #:optional (profile %guix-home)
+          #:key (list-installed-regex #f))
   "Display a summary of home-environment generation NUMBER in a
 human-readable format."
   (define (display-channel channel)
@@ -782,9 +795,16 @@ (define-values (channels config-file)
         (format #t (G_ "  configuration file: ~a~%")
                 (if (supports-hyperlinks?)
                     (file-hyperlink config-file)
-                    config-file))))))
-
-(define* (list-generations pattern #:optional (profile %guix-home))
+                    config-file)))
+      (when list-installed-regex
+        (format #t (G_ "  packages:\n"))
+        (pretty-print-table (list-installed
+                             list-installed-regex
+                             (list (string-append generation "/profile")))
+                            #:left-pad 4)))))
+
+(define* (list-generations pattern #:optional (profile %guix-home)
+                           #:key (list-installed-regex #f))
   "Display in a human-readable format all the home environment
 generations matching PATTERN, a string.  When PATTERN is #f, display
 all the home environment generations."
@@ -792,14 +812,18 @@ (define* (list-generations pattern #:optional (profile %guix-home))
          (raise (condition (&profile-not-found-error
                             (profile profile)))))
         ((not pattern)
-         (for-each display-home-environment-generation (profile-generations profile)))
+         (for-each (cut display-home-environment-generation <>
+                        #:list-installed-regex list-installed-regex)
+                   (profile-generations profile)))
         ((matching-generations pattern profile)
          =>
          (lambda (numbers)
            (if (null-list? numbers)
                (exit 1)
-               (leave-on-EPIPE
-                (for-each display-home-environment-generation numbers)))))))
+               (leave-on-EPIPE (for-each
+                                (cut display-home-environment-generation <>
+                                     #:list-installed-regex list-installed-regex)
+                                numbers)))))))
 
 \f
 ;;;
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 99a6cfaa29..af61b50222 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -11,6 +11,7 @@
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
 ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
+;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -67,6 +68,7 @@ (define-module (guix scripts package)
             delete-generations
             delete-matching-generations
             guix-package
+            list-installed
 
             search-path-environment-variables
             manifest-entry-version-prefix
@@ -773,6 +775,20 @@ (define absolute
 
   (add-indirect-root store absolute))
 
+(define (list-installed regexp profiles)
+  (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
+         (manifest  (concatenate-manifests
+                     (map profile-manifest profiles)))
+         (installed (manifest-entries manifest)))
+    (leave-on-EPIPE
+     (let ((rows (filter-map
+                  (match-lambda
+                    (($ <manifest-entry> name version output path _)
+                     (and (regexp-exec regexp name)
+                          (list name (or version "?") output path))))
+                  installed)))
+       rows))))
+
 \f
 ;;;
 ;;; Queries and actions.
@@ -824,19 +840,8 @@ (define (diff-profiles profile numbers)
        #t)
 
       (('list-installed regexp)
-       (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
-              (manifest  (concatenate-manifests
-                          (map profile-manifest profiles)))
-              (installed (manifest-entries manifest)))
-         (leave-on-EPIPE
-          (let ((rows (filter-map
-                       (match-lambda
-                         (($ <manifest-entry> name version output path _)
-                          (and (regexp-exec regexp name)
-                               (list name (or version "?") output path))))
-                       installed)))
-            ;; Show most recently installed packages last.
-            (pretty-print-table (reverse rows)))))
+       ;; Show most recently installed packages last.
+       (pretty-print-table (reverse (list-installed regexp profiles)))
        #t)
 
       (('list-available regexp)
diff --git a/guix/utils.scm b/guix/utils.scm
index 745da98a79..8484442b29 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1124,7 +1124,7 @@ (define* (string-closest trial tests #:key (threshold 3))
 ;;; Prettified output.
 ;;;
 
-(define* (pretty-print-table rows #:key (max-column-width 20))
+(define* (pretty-print-table rows #:key (max-column-width 20) (left-pad 0))
   "Print ROWS in neat columns.  All rows should be lists of strings and each
 row should have the same length.  The columns are separated by a tab
 character, and aligned using spaces.  The maximum width of each column is
@@ -1143,7 +1143,7 @@ (define* (pretty-print-table rows #:key (max-column-width 20))
                               (map (cut min <> max-column-width)
                                    column-widths)))
          (fmt (string-append (string-join column-formats "\t") "\t~a")))
-    (for-each (cut format #t "~?~%" fmt <>) rows)))
+    (for-each (cut format #t "~v_~?~%" left-pad fmt <>) rows)))
 
 ;;; Local Variables:
 ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
-- 
2.36.1