TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Alex Kost 2014-10-08 17:15:49 +04:00 committed by Ludovic Courtès
parent 12703d0854
commit 5d7a8584f5
6 changed files with 130 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
emacs/guix-main.scm
View File

@ -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?

93
guix/profiles.scm
View File

@ -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.

2
guix/scripts/package.scm
View File

@ -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?

93
guix/ui.scm
View File

@ -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."

17
tests/profiles.scm
View File

@ -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

36
tests/ui.scm
View File

@ -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")