From: Alex Kost <alezost@gmail.com>
To: "Ludovic Courtès" <ludo@gnu.org>
Cc: guix-devel@gnu.org
Subject: Re: ui: Move 'show-manifest-transaction' from (guix profiles).
Date: Wed, 08 Oct 2014 21:57:43 +0400 [thread overview]
Message-ID: <87a956igvc.fsf@gmail.com> (raw)
In-Reply-To: <87eguiiqzt.fsf@gmail.com> (Alex Kost's message of "Wed, 08 Oct 2014 18:19:02 +0400")
[-- Attachment #1: Type: text/plain, Size: 286 bytes --]
Sorry, I've found that the patch I sent is not cleanly applied to the
latest master checkout. The modified patch is attached.
It seems the fail happens only if there is
#:use-module (guix profiles)
in (guix ui). If (guix profiles) is not used, there are no problems.
I'm stuck.
[-- Attachment #2: 0001-ui-Move-show-manifest-transaction-from-guix-profiles.patch --]
[-- Type: text/x-diff, Size: 15714 bytes --]
From 480c22f37437ce138d4fe822f5b1c15f1f65be0e Mon Sep 17 00:00:00 2001
From: Alex Kost <alezost@gmail.com>
Date: Wed, 8 Oct 2014 17:15:49 +0400
Subject: [PATCH] ui: Move 'show-manifest-transaction' from (guix profiles).
* guix/profiles.scm: Do not use (guix ui) module.
(right-arrow, manifest-show-transaction): Move and rename to...
* guix/ui.scm (right-arrow, show-manifest-transaction): ... here.
* tests/profiles.scm ("manifest-show-transaction"): Move to...
* tests/ui.scm ("show-manifest-transaction"): ... here.
(guile-1.8.8, guile-2.0.9): New variables.
* emacs/guix-main.scm (process-package-actions): Rename
'manifest-show-transaction' to 'show-manifest-transaction'.
* guix/scripts/package.scm (guix-package): Likewise.
---
emacs/guix-main.scm | 2 +-
guix/profiles.scm | 93 ------------------------------------------------
guix/scripts/package.scm | 2 +-
guix/ui.scm | 93 ++++++++++++++++++++++++++++++++++++++++++++++++
tests/profiles.scm | 17 ---------
tests/ui.scm | 32 +++++++++++++++++
6 files changed, 127 insertions(+), 112 deletions(-)
diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm
index b85bb5c..fe599fb 100644
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -797,7 +797,7 @@ OUTPUTS is a list of package outputs (may be an empty list)."
(new-profile (derivation->output-path derivation)))
(set-build-options store
#:use-substitutes? use-substitutes?)
- (manifest-show-transaction store manifest transaction
+ (show-manifest-transaction store manifest transaction
#:dry-run? dry-run?)
(show-what-to-build store derivations
#:use-substitutes? use-substitutes?
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 18733a6..f2eb754 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -19,7 +19,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix profiles)
- #:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix derivations)
@@ -63,7 +62,6 @@
manifest-transaction-remove
manifest-perform-transaction
manifest-transaction-effects
- manifest-show-transaction
profile-manifest
package->manifest-entry
@@ -315,97 +313,6 @@ it."
(manifest-add (manifest-remove manifest remove)
install)))
-(define (right-arrow port)
- "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
-replacement if PORT is not Unicode-capable."
- (with-fluids ((%default-port-encoding (port-encoding port)))
- (let ((arrow "→"))
- (catch 'encoding-error
- (lambda ()
- (call-with-output-string
- (lambda (port)
- (set-port-conversion-strategy! port 'error)
- (display arrow port))))
- (lambda (key . args)
- "->")))))
-
-(define* (manifest-show-transaction store manifest transaction
- #:key dry-run?)
- "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
- (define (package-strings name version output item)
- (map (lambda (name version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a\t~a"
- name
- (equal? output "out") output version
- (if (package? item)
- (package-output store item output)
- item)))
- name version output item))
-
- (define → ;an arrow that can be represented on stderr
- (right-arrow (current-error-port)))
-
- (define (upgrade-string name old-version new-version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
- name (equal? output "out") output
- old-version → new-version
- (if (package? item)
- (package-output store item output)
- item)))
-
- (let-values (((remove install upgrade)
- (manifest-transaction-effects manifest transaction)))
- (match remove
- ((($ <manifest-entry> name version output item) ..1)
- (let ((len (length name))
- (remove (package-strings name version output item)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be removed:~%~{~a~%~}~%"
- "The following packages would be removed:~%~{~a~%~}~%"
- len)
- remove)
- (format (current-error-port)
- (N_ "The following package will be removed:~%~{~a~%~}~%"
- "The following packages will be removed:~%~{~a~%~}~%"
- len)
- remove))))
- (_ #f))
- (match upgrade
- (((($ <manifest-entry> name old-version)
- . ($ <manifest-entry> _ new-version output item)) ..1)
- (let ((len (length name))
- (upgrade (map upgrade-string
- name old-version new-version output item)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be upgraded:~%~{~a~%~}~%"
- "The following packages would be upgraded:~%~{~a~%~}~%"
- len)
- upgrade)
- (format (current-error-port)
- (N_ "The following package will be upgraded:~%~{~a~%~}~%"
- "The following packages will be upgraded:~%~{~a~%~}~%"
- len)
- upgrade))))
- (_ #f))
- (match install
- ((($ <manifest-entry> name version output item _) ..1)
- (let ((len (length name))
- (install (package-strings name version output item)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be installed:~%~{~a~%~}~%"
- "The following packages would be installed:~%~{~a~%~}~%"
- len)
- install)
- (format (current-error-port)
- (N_ "The following package will be installed:~%~{~a~%~}~%"
- "The following packages will be installed:~%~{~a~%~}~%"
- len)
- install))))
- (_ #f))))
-
\f
;;;
;;; Profiles.
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index fc9c37b..031f71a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -770,7 +770,7 @@ more information.~%"))
new
#:info-dir? (not bootstrap?))))
(prof (derivation->output-path prof-drv)))
- (manifest-show-transaction (%store) manifest transaction
+ (show-manifest-transaction (%store) manifest transaction
#:dry-run? dry-run?)
(show-what-to-build (%store) (list prof-drv)
#:use-substitutes?
diff --git a/guix/ui.scm b/guix/ui.scm
index 04345d4..9778dca 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -23,6 +23,7 @@
#:use-module (guix store)
#:use-module (guix config)
#:use-module (guix packages)
+ #:use-module (guix profiles)
#:use-module (guix build-system)
#:use-module (guix derivations)
#:use-module ((guix build utils) #:select (mkdir-p))
@@ -47,6 +48,7 @@
string->number*
size->number
show-what-to-build
+ show-manifest-transaction
call-with-error-handling
with-error-handling
read/eval
@@ -347,6 +349,97 @@ available for download."
(null? download) download)))
(pair? build)))
+(define (right-arrow port)
+ "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
+replacement if PORT is not Unicode-capable."
+ (with-fluids ((%default-port-encoding (port-encoding port)))
+ (let ((arrow "→"))
+ (catch 'encoding-error
+ (lambda ()
+ (call-with-output-string
+ (lambda (port)
+ (set-port-conversion-strategy! port 'error)
+ (display arrow port))))
+ (lambda (key . args)
+ "->")))))
+
+(define* (show-manifest-transaction store manifest transaction
+ #:key dry-run?)
+ "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
+ (define (package-strings name version output item)
+ (map (lambda (name version output item)
+ (format #f " ~a~:[:~a~;~*~]\t~a\t~a"
+ name
+ (equal? output "out") output version
+ (if (package? item)
+ (package-output store item output)
+ item)))
+ name version output item))
+
+ (define → ;an arrow that can be represented on stderr
+ (right-arrow (current-error-port)))
+
+ (define (upgrade-string name old-version new-version output item)
+ (format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
+ name (equal? output "out") output
+ old-version → new-version
+ (if (package? item)
+ (package-output store item output)
+ item)))
+
+ (let-values (((remove install upgrade)
+ (manifest-transaction-effects manifest transaction)))
+ (match remove
+ ((($ <manifest-entry> name version output item) ..1)
+ (let ((len (length name))
+ (remove (package-strings name version output item)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be removed:~%~{~a~%~}~%"
+ "The following packages would be removed:~%~{~a~%~}~%"
+ len)
+ remove)
+ (format (current-error-port)
+ (N_ "The following package will be removed:~%~{~a~%~}~%"
+ "The following packages will be removed:~%~{~a~%~}~%"
+ len)
+ remove))))
+ (_ #f))
+ (match upgrade
+ (((($ <manifest-entry> name old-version)
+ . ($ <manifest-entry> _ new-version output item)) ..1)
+ (let ((len (length name))
+ (upgrade (map upgrade-string
+ name old-version new-version output item)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be upgraded:~%~{~a~%~}~%"
+ "The following packages would be upgraded:~%~{~a~%~}~%"
+ len)
+ upgrade)
+ (format (current-error-port)
+ (N_ "The following package will be upgraded:~%~{~a~%~}~%"
+ "The following packages will be upgraded:~%~{~a~%~}~%"
+ len)
+ upgrade))))
+ (_ #f))
+ (match install
+ ((($ <manifest-entry> name version output item _) ..1)
+ (let ((len (length name))
+ (install (package-strings name version output item)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be installed:~%~{~a~%~}~%"
+ "The following packages would be installed:~%~{~a~%~}~%"
+ len)
+ install)
+ (format (current-error-port)
+ (N_ "The following package will be installed:~%~{~a~%~}~%"
+ "The following packages will be installed:~%~{~a~%~}~%"
+ len)
+ install))))
+ (_ #f))))
+
(define-syntax with-error-handling
(syntax-rules ()
"Run BODY within a user-friendly error condition handler."
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 99f1fd2..61c801c 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -156,23 +156,6 @@
(equal? (list glibc) install)
(equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
-(test-assert "manifest-show-transaction"
- (let* ((m (manifest (list guile-1.8.8)))
- (t (manifest-transaction (install (list guile-2.0.9)))))
- (let-values (((remove install upgrade)
- (manifest-transaction-effects m t)))
- (with-store store
- (and (string-match "guile\t1.8.8 → 2.0.9"
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-error-to-string
- (lambda ()
- (manifest-show-transaction store m t)))))
- (string-match "guile\t1.8.8 -> 2.0.9"
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (with-error-to-string
- (lambda ()
- (manifest-show-transaction store m t))))))))))
-
(test-assert "profile-derivation"
(run-with-store %store
(mlet* %store-monad
diff --git a/tests/ui.scm b/tests/ui.scm
index db90cdd..ed4cd06 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -19,6 +19,7 @@
(define-module (test-ui)
#:use-module (guix ui)
+ #:use-module (guix profiles)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (srfi srfi-1)
@@ -35,6 +36,20 @@ R6RS, Guile includes a module system, full access to POSIX system calls,
networking support, multiple threads, dynamic linking, a foreign function call
interface, and powerful string processing.")
+(define guile-1.8.8
+ (manifest-entry
+ (name "guile")
+ (version "1.8.8")
+ (item "/gnu/store/...")
+ (output "out")))
+
+(define guile-2.0.9
+ (manifest-entry
+ (name "guile")
+ (version "2.0.9")
+ (item "/gnu/store/...")
+ (output "out")))
+
\f
(test-begin "ui")
@@ -210,6 +225,23 @@ Second line" 24))
;; This should print nothing.
(show-what-to-build store (list drv)))))))
+(test-assert "show-manifest-transaction"
+ (let* ((m (manifest (list guile-1.8.8)))
+ (t (manifest-transaction (install (list guile-2.0.9)))))
+ (let-values (((remove install upgrade)
+ (manifest-transaction-effects m t)))
+ (with-store store
+ (and (string-match "guile\t1.8.8 → 2.0.9"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (with-error-to-string
+ (lambda ()
+ (show-manifest-transaction store m t)))))
+ (string-match "guile\t1.8.8 -> 2.0.9"
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (with-error-to-string
+ (lambda ()
+ (show-manifest-transaction store m t))))))))))
+
(test-end "ui")
\f
--
2.1.2
next prev parent reply other threads:[~2014-10-08 17:57 UTC|newest]
Thread overview: 12+ messages / expand[flat|nested] mbox.gz Atom feed top
2014-10-08 14:19 ui: Move 'show-manifest-transaction' from (guix profiles) Alex Kost
2014-10-08 17:57 ` Alex Kost [this message]
2014-10-08 19:55 ` Ludovic Courtès
2014-10-09 6:31 ` Alex Kost
2014-10-09 21:03 ` Ludovic Courtès
2014-10-09 22:08 ` Ludovic Courtès
2014-10-10 7:00 ` Alex Kost
2014-10-10 12:15 ` Ludovic Courtès
2014-10-10 15:20 ` Alex Kost
2014-10-11 21:57 ` Ludovic Courtès
2014-10-12 5:39 ` [PATCH 2/2] emacs: Add support for switching generations Alex Kost
2014-10-12 21:04 ` 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
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87a956igvc.fsf@gmail.com \
--to=alezost@gmail.com \
--cc=guix-devel@gnu.org \
--cc=ludo@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 external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.