M emacs/guix-main.scm => emacs/guix-main.scm +1 -1
@@ 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?
M guix/profiles.scm => guix/profiles.scm +0 -93
@@ 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))))
-
;;;
;;; Profiles.
M guix/scripts/package.scm => guix/scripts/package.scm +1 -1
@@ 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?
M guix/ui.scm => guix/ui.scm +93 -0
@@ 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
@@ 348,6 350,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."
M tests/profiles.scm => tests/profiles.scm +0 -17
@@ 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
M tests/ui.scm => tests/ui.scm +35 -1
@@ 19,11 19,14 @@
(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)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
- #:use-module (srfi srfi-64))
+ #:use-module (srfi srfi-64)
+ #:use-module (ice-9 regex))
;; Test the (guix ui) module.
@@ 35,6 38,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")))
+
(test-begin "ui")
@@ 210,6 227,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")