;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;; Avoid "overrides core binding" warning.
delete))
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
Report bugs to: ~a.") %guix-bug-report-address)
(format #t (G_ "
~a home page: <~a>") %guix-package-name %guix-home-page-url)
- (display (G_ "
-General help using GNU software: <http://www.gnu.org/gethelp/>"))
+ (format #t (G_ "
+General help using Guix and GNU software: <~a>")
+ "https://guix.gnu.org/help/")
(newline))
(define (augmented-system-error-handler file)
(null? hook) (map colorized-store-item hook)))
((= verbosity 1)
;; Display the bare minimum; don't mention grafts and hooks.
+ (unless (null? build)
+ (newline (current-error-port)))
(if display-download-size?
(format (current-error-port)
;; TRANSLATORS: "MB" is for "megabyte"; it should be
;; translated to the corresponding abbreviation.
- (G_ "~:[~,1h MB would be downloaded~%~;~]")
+ (highlight (G_ "~:[~,1h MB would be downloaded~%~;~]"))
(null? download) download-size)
(format (current-error-port)
- (N_ "~:[~h item would be downloaded~%~;~]"
- "~:[~h items would be downloaded~%~;~]"
- (length download))
+ (highlight
+ (N_ "~:[~h item would be downloaded~%~;~]"
+ "~:[~h items would be downloaded~%~;~]"
+ (length download)))
(null? download) (length download))))))
(begin
(null? hook) (map colorized-store-item hook)))
((= verbosity 1)
;; Display the bare minimum; don't mention grafts and hooks.
+ (unless (null? build)
+ (newline (current-error-port)))
(if display-download-size?
(format (current-error-port)
;; TRANSLATORS: "MB" is for "megabyte"; it should be
;; translated to the corresponding abbreviation.
- (G_ "~:[~,1h MB will be downloaded~%~;~]")
+ (highlight (G_ "~:[~,1h MB will be downloaded~%~;~]"))
(null? download) download-size)
(format (current-error-port)
- (N_ "~:[~h item will be downloaded~%~;~]"
- "~:[~h items will be downloaded~%~;~]"
- (length download))
+ (highlight
+ (N_ "~:[~h item will be downloaded~%~;~]"
+ "~:[~h items will be downloaded~%~;~]"
+ (length download)))
(null? download) (length download)))))))
(check-available-space installed-size)
(define* (show-manifest-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
- (define (package-strings names versions outputs)
- (tabulate (zip (map (lambda (name output)
- (if (string=? output "out")
- name
- (string-append name ":" output)))
- names outputs)
- versions)
+ (define* (package-strings names versions outputs #:key old-versions)
+ (tabulate (stable-sort
+ (zip (map (lambda (name output)
+ (if (string=? output "out")
+ name
+ (string-append name ":" output)))
+ names outputs)
+ (if old-versions
+ (map (lambda (old new)
+ (if (string=? old new)
+ (G_ "(dependencies or package changed)")
+ (string-append old " " → " " new)))
+ old-versions versions)
+ versions))
+ (lambda (x y)
+ (string<? (first x) (first y))))
#:initial-indent 3))
(define → ;an arrow that can be represented on stderr
(right-arrow (current-error-port)))
- (define (upgrade-string names old-version new-version outputs)
- (tabulate (zip (map (lambda (name output)
- (if (string=? output "out")
- name
- (string-append name ":" output)))
- names outputs)
- (map (lambda (old new)
- (if (string=? old new)
- (G_ "(dependencies or package changed)")
- (string-append old " " → " " new)))
- old-version new-version))
- #:initial-indent 3))
-
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (downgrade (upgrade-string name old-version new-version
- output)))
+ (downgrade (package-strings name new-version output
+ #:old-versions old-version)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be downgraded:~%~{~a~%~}~%"
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (upgrade (upgrade-string name
- old-version new-version
- output)))
+ (upgrade (package-strings name new-version output
+ #:old-versions old-version)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%"
(G_ "Try `guix --help' for more information.~%"))
(exit 1))
+;; Representation of a 'guix' command.
+(define-immutable-record-type <command>
+ (command name synopsis category)
+ command?
+ (name command-name)
+ (synopsis command-synopsis)
+ (category command-category))
+
+(define (source-file-command file)
+ "Read FILE, a Scheme source file, and return either a <command> object based
+on the 'define-command' top-level form found therein, or #f if FILE does not
+contain a 'define-command' form."
+ (define command-name
+ (match (string-split file #\/)
+ ((_ ... "guix" "scripts" name)
+ (list (file-sans-extension name)))
+ ((_ ... "guix" "scripts" first second)
+ (list first (file-sans-extension second)))))
+
+ ;; The strategy here is to parse FILE. This is much cheaper than a
+ ;; technique based on run-time introspection where we'd load FILE and all
+ ;; the modules it depends on.
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ()
+ (match (read port)
+ (('define-command _ ('synopsis synopsis)
+ _ ...)
+ (command command-name synopsis 'main))
+ (('define-command _
+ ('category category) ('synopsis synopsis)
+ _ ...)
+ (command command-name synopsis category))
+ ((? eof-object?)
+ #f)
+ (_
+ (loop)))))))
+
(define (command-files)
"Return the list of source files that define Guix sub-commands."
(define directory
(cut string-suffix? ".scm" <>))
(if directory
- (scandir directory dot-scm?)
+ (map (cut string-append directory "/" <>)
+ (scandir directory dot-scm?))
'()))
(define (commands)
- "Return the list of Guix command names."
- (map (compose (cut string-drop-right <> 4)
- basename)
- (command-files)))
+ "Return the list of commands, alphabetically sorted."
+ (filter-map source-file-command (command-files)))
(define (show-guix-help)
(define (internal? command)
(member command '("substitute" "authenticate" "offload"
"perform-download")))
+ (define (display-commands commands)
+ (let* ((names (map (lambda (command)
+ (string-join (command-name command)))
+ commands))
+ (max-width (reduce max 0 (map string-length names))))
+ (for-each (lambda (name command)
+ (format #t " ~a ~a~%"
+ (string-pad-right name max-width)
+ (G_ (command-synopsis command))))
+ names
+ commands)))
+
+ (define (category-predicate category)
+ (lambda (command)
+ (eq? category (command-category command))))
+
(format #t (G_ "Usage: guix COMMAND ARGS...
Run COMMAND with ARGS.\n"))
(newline)
(format #t (G_ "COMMAND must be one of the sub-commands listed below:\n"))
- (newline)
- ;; TODO: Display a synopsis of each command.
- (format #t "~{ ~a~%~}" (sort (remove internal? (commands))
- string<?))
+
+ (let ((commands (commands))
+ (categories (module-ref (resolve-interface '(guix scripts))
+ '%command-categories)))
+ (for-each (match-lambda
+ (('internal . _)
+ #t) ;hide internal commands
+ ((category . synopsis)
+ (format #t "~% ~a~%" (G_ synopsis))
+ (display-commands (filter (category-predicate category)
+ commands))))
+ categories))
(show-bug-report-information))
(define (run-guix-command command . args)
HCoop / jackhill / guix / guix.git / blobdiff