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

[Andrew Tropin <andrew@trop.in>]

[-- Attachment #1: Type: text/plain, Size: 11249 bytes --]

On 2022-07-12 22:50, Antero Mejr wrote:

> * 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)

Applied locally, tested, LGTM.

-- 
Best regards,
Andrew Tropin

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]