From: "Ludovic Courtès" <ludo@gnu.org>
To: 32115@debbugs.gnu.org
Subject: [bug#32115] [PATCH 2/2] pull: Use (guix inferior) to display new and upgraded packages.
Date: Tue, 10 Jul 2018 18:48:08 +0200 [thread overview]
Message-ID: <20180710164809.20285-5-ludo@gnu.org> (raw)
In-Reply-To: <20180710164809.20285-1-ludo@gnu.org>
* guix/scripts/pull.scm (display-profile-content): Call
'display-generation'.
(display-profile-content-diff): New procedure.
(process-query)[list-generation]: Remove.
[list-generations]: New procedure.
Adjust accordingly.
* doc/guix.texi (Invoking guix pull): Update example of '-l'.
---
doc/guix.texi | 6 +++
guix/scripts/pull.scm | 91 +++++++++++++++++++++++++++++++++++++------
2 files changed, 86 insertions(+), 11 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index e93b320e8..3e4bceb8a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2786,12 +2786,18 @@ Generation 2 Jun 11 2018 11:02:49
repository URL: https://git.savannah.gnu.org/git/guix.git
branch: origin/master
commit: e0cc7f669bec22c37481dd03a7941c7d11a64f1d
+ 2 new packages: keepalived, libnfnetlink
+ 6 packages upgraded: emacs-nix-mode@@2.0.4,
+ guile2.0-guix@@0.14.0-12.77a1aac, guix@@0.14.0-12.77a1aac,
+ heimdal@@7.5.0, milkytracker@@1.02.00, nix@@2.0.4
Generation 3 Jun 13 2018 23:31:07 (current)
guix 844cc1c
repository URL: https://git.savannah.gnu.org/git/guix.git
branch: origin/master
commit: 844cc1c8f394f03b404c5bb3aee086922373490c
+ 28 new packages: emacs-helm-ls-git, emacs-helm-mu, @dots{}
+ 69 packages upgraded: borg@@1.1.6, cheese@@3.28.0, @dots{}
@end example
This @code{~/.config/guix/current} profile works like any other profile
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7202e3cc1..c61432b04 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -29,6 +29,7 @@
#:use-module (guix gexp)
#:use-module (guix grafts)
#:use-module (guix monads)
+ #:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
#:autoload (guix self) (whole-package)
#:autoload (gnu packages ssh) (guile-ssh)
@@ -45,9 +46,11 @@
#:use-module ((gnu packages certs) #:select (le-certs))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (guix-pull))
(module-autoload! (resolve-module '(guix scripts pull))
@@ -289,6 +292,7 @@ certificates~%"))
(define (display-profile-content profile number)
"Display the packages in PROFILE, generation NUMBER, in a human-readable
way and displaying details about the channel's source code."
+ (display-generation profile number)
(for-each (lambda (entry)
(format #t " ~a ~a~%"
(manifest-entry-name entry)
@@ -310,6 +314,68 @@ way and displaying details about the channel's source code."
(manifest-entries
(profile-manifest (generation-file-name profile number))))))
+(define (indented-string str indent)
+ "Return STR with each newline preceded by IDENT spaces."
+ (define indent-string
+ (make-list indent #\space))
+
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (if (eqv? chr #\newline)
+ (cons chr (append indent-string result))
+ (cons chr result)))
+ '()
+ str)))
+
+(define (display-profile-content-diff profile gen1 gen2)
+ "Display the changes in PROFILE GEN2 compared to generation GEN1."
+ (define (package-alist generation)
+ (fold (lambda (package lst)
+ (alist-cons (inferior-package-name package)
+ (inferior-package-version package)
+ lst))
+ '()
+ (let* ((directory (generation-file-name profile generation))
+ (inferior (open-inferior directory))
+ (packages (inferior-packages inferior)))
+ (close-inferior inferior)
+ packages)))
+
+ (display-profile-content profile gen2)
+ (let* ((gen1 (fold (match-lambda*
+ (((name . version) table)
+ (vhash-cons name version table)))
+ vlist-null
+ (package-alist gen1)))
+ (gen2 (package-alist gen2))
+ (new (remove (match-lambda
+ ((name . _)
+ (vhash-assoc name gen1)))
+ gen2))
+ (upgraded (filter-map (match-lambda
+ ((name . new-version)
+ (match (vhash-fold* cons '() name gen1)
+ (() #f)
+ ((= (cut sort <> version>?) old-versions)
+ (and (version>? new-version
+ (first old-versions))
+ (string-append name "@"
+ new-version))))))
+ gen2)))
+ (unless (null? new)
+ (format #t (G_ " ~h new packages: ~a~%") (length new)
+ (indented-string
+ (fill-paragraph (string-join (sort (map first new) string<?)
+ ", ")
+ (- (%text-width) 4) 30)
+ 4)))
+ (unless (null? upgraded)
+ (format #t (G_ " ~h packages upgraded: ~a~%") (length upgraded)
+ (indented-string
+ (fill-paragraph (string-join (sort upgraded string<?) ", ")
+ (- (%text-width) 4) 35)
+ 4)))))
+
(define (process-query opts)
"Process any query specified by OPTS."
(define profile
@@ -317,29 +383,32 @@ way and displaying details about the channel's source code."
(match (assoc-ref opts 'query)
(('list-generations pattern)
- (define (list-generation display-function number)
- (unless (zero? number)
- (display-generation profile number)
- (display-function profile number)
- (newline)))
+ (define (list-generations profile numbers)
+ (match numbers
+ ((first rest ...)
+ (display-profile-content profile first)
+ (let loop ((numbers numbers))
+ (match numbers
+ ((first second rest ...)
+ (display-profile-content-diff profile
+ first second)
+ (loop (cons second rest)))
+ ((_) #t)
+ (() #t))))))
(leave-on-EPIPE
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
((string-null? pattern)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- (profile-generations profile)))
+ (list-generations profile (profile-generations profile)))
((matching-generations pattern profile)
=>
(match-lambda
(()
(exit 1))
((numbers ...)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- numbers)))))))))
+ (list-generations profile numbers)))))))))
\f
(define (guix-pull . args)
--
2.18.0
next prev parent reply other threads:[~2018-07-10 16:49 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-07-10 16:45 [bug#32115] [PATCH 0/2] Add (guix inferior) and improve 'guix pull -l' Ludovic Courtès
2018-07-10 16:48 ` [bug#32115] [PATCH 1/2] Add (guix inferior) and (guix scripts repl) Ludovic Courtès
2018-07-10 16:48 ` [bug#32115] [PATCH 1/2] Add (guix inferior) Ludovic Courtès
2018-07-10 16:48 ` [bug#32115] [PATCH 1/3] profiles: Factorize 'manifest-search-paths' Ludovic Courtès
2018-07-10 16:48 ` [bug#32115] [PATCH 2/3] environment: Simplify code by using manifests internally Ludovic Courtès
2018-07-10 16:48 ` Ludovic Courtès [this message]
2018-07-10 16:48 ` [bug#32115] [PATCH 3/3] profiles: Introduce 'profile-search-paths' and use it Ludovic Courtès
2018-07-10 16:50 ` [bug#32115] [PATCH 1/2] Add (guix inferior) and (guix scripts repl) Ludovic Courtès
2018-07-13 15:59 ` bug#32115: [PATCH 0/2] Add (guix inferior) and improve 'guix pull -l' Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180710164809.20285-5-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=32115@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).