#:use-module (srfi srfi-19)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
- #:export (args-fold*
+ #:export (synopsis
+ category
+ define-command
+ %command-categories
+
+ args-fold*
parse-command-line
maybe-build
build-package
;;;
;;; Code:
+;; Syntactic keywords.
+(define synopsis 'command-synopsis)
+(define category 'command-category)
+
+(define-syntax define-command-categories
+ (syntax-rules (G_)
+ "Define command categories."
+ ((_ name assert-valid (identifiers (G_ synopses)) ...)
+ (begin
+ (define-public identifiers
+ ;; Define and export syntactic keywords.
+ (list 'syntactic-keyword-for-command-category))
+ ...
+
+ (define-syntax assert-valid
+ ;; Validate at expansion time that we're passed a valid category.
+ (syntax-rules (identifiers ...)
+ ((_ identifiers) #t)
+ ...))
+
+ (define name
+ ;; Alist mapping category name to synopsis.
+ `((identifiers . synopses) ...))))))
+
+;; Command categories.
+(define-command-categories %command-categories
+ assert-valid-command-category
+ (main (G_ "main commands"))
+ (development (G_ "software development commands"))
+ (packaging (G_ "packaging commands"))
+ (plumbing (G_ "plumbing commands"))
+ (internal (G_ "internal commands")))
+
+(define-syntax define-command
+ (syntax-rules (category synopsis)
+ "Define the given command as a procedure along with its synopsis and,
+optionally, its category. The synopsis becomes the docstring of the
+procedure, but both the category and synopsis are meant to be read (parsed) by
+'guix help'."
+ ;; The (synopsis ...) form is here so that xgettext sees those strings as
+ ;; translatable.
+ ((_ (name . args)
+ (synopsis doc) body ...)
+ (define (name . args)
+ doc
+ body ...))
+ ((_ (name . args)
+ (category cat) (synopsis doc)
+ body ...)
+ (begin
+ (assert-valid-command-category cat)
+ (define (name . args)
+ doc
+ body ...)))))
+
(define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error
reporting."
;;; Entry point.
;;;
-(define (guix-archive . args)
+(define-command (guix-archive . args)
+ (category plumbing)
+ (synopsis "manipulate, export, and import normalized archives (nars)")
+
(define (lines port)
;; Return lines read from PORT.
(let loop ((line (read-line port))
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix scripts authenticate)
#:use-module (guix config)
+ #:use-module (guix scripts)
#:use-module (guix base16)
#:use-module (gcrypt pk-crypto)
#:use-module (guix pki)
;;; unmodified currently.
;;;
-(define (guix-authenticate . args)
+(define-command (guix-authenticate . args)
+ (category internal)
+ (synopsis "sign or verify signatures on normalized archives (nars)")
+
;; Signature sexps written to stdout may contain binary data, so force
;; ISO-8859-1 encoding so that things are not mangled. See
;; <http://bugs.gnu.org/17312> for details.
;;; Entry point.
;;;
-(define (guix-build . args)
+(define-command (guix-build . args)
+ (category packaging)
+ (synopsis "build packages or derivations without installing them")
+
(define opts
(parse-command-line args %options
(list %default-options)))
;;; Entry point.
;;;
-(define (guix-challenge . args)
+(define-command (guix-challenge . args)
+ (category packaging)
+ (synopsis "challenge substitute servers, comparing their binaries")
+
(with-error-handling
(let* ((opts (parse-command-line args %options (list %default-options)
#:build-options? #f))
(define-module (guix scripts container)
#:use-module (ice-9 match)
#:use-module (guix ui)
+ #:use-module (guix scripts)
#:export (guix-container))
(define (show-help)
(proc (string->symbol (string-append "guix-container-" name))))
(module-ref module proc)))
-(define (guix-container . args)
+(define-command (guix-container . args)
+ (category development)
+ (synopsis "run code in containers created by 'guix environment -C'")
+
(with-error-handling
(match args
(()
;;; Entry point.
;;;
-(define (guix-copy . args)
+(define-command (guix-copy . args)
+ (category plumbing)
+ (synopsis "copy store items remotely over SSH")
+
(with-error-handling
(let* ((opts (parse-command-line args %options (list %default-options)))
(source (assoc-ref opts 'source))
(machine-display-name machine))))
\f
-(define (guix-deploy . args)
+(define-command (guix-deploy . args)
+ (synopsis "deploy operating systems on a set of machines")
(define (handle-argument arg result)
(alist-cons 'file arg result))
;;; Entry point.
;;;
-(define (guix-describe . args)
+(define-command (guix-describe . args)
+ (synopsis "describe the channel revisions currently used")
(let* ((opts (args-fold* args %options
(lambda (opt name arg result)
(leave (G_ "~A: unrecognized option~%")
;;; Entry point.
;;;
-(define (guix-download . args)
+(define-command (guix-download . args)
+ (category packaging)
+ (synopsis "download a file to the store and print its hash")
+
(define (parse-options)
;; Return the alist of option values.
(args-fold* args %options
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
(search-path* %load-path (location-file location))))
\f
-(define (guix-edit . args)
+(define-command (guix-edit . args)
+ (category packaging)
+ (synopsis "view and edit package definitions")
+
(define (parse-arguments)
;; Return the list of package names.
(args-fold* args %options
;;; Entry point.
;;;
-(define (guix-environment . args)
+(define-command (guix-environment . args)
+ (category development)
+ (synopsis "spawn one-off software environments")
+
(with-error-handling
(let* ((opts (parse-args args))
(pure? (assoc-ref opts 'pure))
;;; Entry point.
;;;
-(define (guix-gc . args)
+(define-command (guix-gc . args)
+ (synopsis "invoke the garbage collector")
+
(define (parse-options)
;; Return the alist of option values.
(parse-command-line args %options (list %default-options)
(define-module (guix scripts git)
#:use-module (ice-9 match)
#:use-module (guix ui)
+ #:use-module (guix scripts)
#:export (guix-git))
(define (show-help)
(proc (string->symbol (string-append "guix-git-" name))))
(module-ref module proc)))
-(define (guix-git . args)
+(define-command (guix-git . args)
+ (category plumbing)
+ (synopsis "operate on Git repositories")
+
(with-error-handling
(match args
(()
;;; Entry point.
;;;
-(define (guix-graph . args)
+(define-command (guix-graph . args)
+ (category packaging)
+ (synopsis "view and query package dependency graphs")
+
(with-error-handling
(define opts
(parse-command-line args %options
;;; Entry point.
;;;
-(define (guix-hash . args)
+(define-command (guix-hash . args)
+ (category packaging)
+ (synopsis "compute the cryptographic hash of a file")
+
(define (parse-options)
;; Return the alist of option values.
(parse-command-line args %options (list %default-options)
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
(define-module (guix scripts import)
#:use-module (guix ui)
+ #:use-module (guix scripts)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
(newline)
(show-bug-report-information))
-(define (guix-import . args)
+(define-command (guix-import . args)
+ (category packaging)
+ (synopsis "import a package definition from an external repository")
+
(match args
(()
(format (current-error-port)
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
%transformation-options
%standard-build-options)))
-(define (guix-install . args)
+(define-command (guix-install . args)
+ (synopsis "install packages")
+
(define (handle-argument arg result arg-handler)
;; Treat all non-option arguments as package specs.
(values (alist-cons 'install arg result)
;;; Entry Point
;;;
-(define (guix-lint . args)
+(define-command (guix-lint . args)
+ (category packaging)
+ (synopsis "validate package definitions")
+
(define (parse-options)
;; Return the alist of option values.
(parse-command-line args %options (list %default-options)
#:select (fcntl-flock set-thread-name))
#:use-module ((guix build utils) #:select (which mkdir-p))
#:use-module (guix ui)
+ #:use-module (guix scripts)
#:use-module (guix diagnostics)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
;;; Entry point.
;;;
-(define (guix-offload . args)
+(define-command (guix-offload . args)
+ (category plumbing)
+ (synopsis "set up and operate build offloading")
+
(define request-line-rx
;; The request format. See 'tryBuildHook' method in build.cc.
(make-regexp "([01]) ([a-z0-9_-]+) (/[[:graph:]]+.drv) ([[:graph:]]*)"))
;;; Entry point.
;;;
-(define (guix-pack . args)
+(define-command (guix-pack . args)
+ (category development)
+ (synopsis "create application bundles")
+
(define opts
(parse-command-line args %options (list %default-options)))
;;; Entry point.
;;;
-(define (guix-package . args)
+(define-command (guix-package . args)
+ (synopsis "manage packages and profiles")
+
(define (handle-argument arg result arg-handler)
;; Process non-option argument ARG by calling back ARG-HANDLER.
(if arg-handler
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix scripts perform-download)
#:use-module (guix ui)
+ #:use-module (guix scripts)
#:use-module (guix derivations)
#:use-module ((guix store) #:select (derivation-path? store-path?))
#:use-module (guix build download)
(leave (G_ "refusing to run with elevated privileges (UID ~a)~%")
(getuid))))
-(define (guix-perform-download . args)
- "Perform the download described by the given fixed-output derivation.
+(define-command (guix-perform-download . args)
+ (category internal)
+ (synopsis "perform download described by fixed-output derivations")
-This is an \"out-of-band\" download in that this code is executed directly by
-the daemon and not explicitly described as an input of the derivation. This
-allows us to sidestep bootstrapping problems, such downloading the source code
-of GnuTLS over HTTPS, before we have built GnuTLS. See
-<http://bugs.gnu.org/22774>."
+ ;; This is an "out-of-band" download in that this code is executed directly
+ ;; by the daemon and not explicitly described as an input of the derivation.
+ ;; This allows us to sidestep bootstrapping problems, such as downloading
+ ;; the source code of GnuTLS over HTTPS before we have built GnuTLS. See
+ ;; <https://bugs.gnu.org/22774>.
(define print-build-trace?
(match (getenv "_NIX_OPTIONS")
;;; Entry point.
;;;
-(define (guix-processes . args)
+(define-command (guix-processes . args)
+ (category plumbing)
+ (synopsis "list currently running sessions")
(define options
(args-fold* args %options
(lambda (opt name arg result)
;;; Entry point.
;;;
-(define (guix-publish . args)
+(define-command (guix-publish . args)
+ (category packaging)
+ (synopsis "publish build results over HTTP")
+
(with-error-handling
(let* ((opts (args-fold* args %options
(lambda (opt name arg result)
channels)))
\f
-(define (guix-pull . args)
+(define-command (guix-pull . args)
+ (synopsis "pull the latest revision of Guix")
+
(with-error-handling
(with-git-error-handling
(let* ((opts (parse-command-line args %options
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; Entry point.
;;;
-(define (guix-refresh . args)
+(define-command (guix-refresh . args)
+ (category packaging)
+ (synopsis "update existing package definitions")
+
(define (parse-options)
;; Return the alist of option values.
(parse-command-line args %options (list %default-options)
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
%standard-build-options)))
-(define (guix-remove . args)
+(define-command (guix-remove . args)
+ (synopsis "remove installed packages")
+
(define (handle-argument arg result arg-handler)
;; Treat all non-option arguments as package specs.
(values (alist-cons 'remove arg result)
(loop)))))))
\f
-(define (guix-repl . args)
+(define-command (guix-repl . args)
+ (category plumbing)
+ (synopsis "read-eval-print loop (REPL) for interactive programming")
+
(define opts
(args-fold* args %options
(lambda (opt name arg result)
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(member "load-path" (option-names option)))
%standard-build-options)))
-(define (guix-search . args)
+(define-command (guix-search . args)
+ (synopsis "search for packages")
+
(define (handle-argument arg result)
;; Treat all non-option arguments as regexps.
(cons `(query search ,(or arg ""))
(member "load-path" (option-names option)))
%standard-build-options)))
-(define (guix-show . args)
+(define-command (guix-show . args)
+ (synopsis "show information about packages")
+
(define (handle-argument arg result)
;; Treat all non-option arguments as regexps.
(cons `(query show ,arg)
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;; Entry point.
;;;
-(define (guix-size . args)
+(define-command (guix-size . args)
+ (category packaging)
+ (synopsis "profile the on-disk size of packages")
+
(with-error-handling
(let* ((opts (parse-command-line args %options (list %default-options)
#:build-options? #f))
(define-module (guix scripts substitute)
#:use-module (guix ui)
+ #:use-module (guix scripts)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix combinators)
(unless (string->uri uri)
(leave (G_ "~a: invalid URI~%") uri)))
-(define (guix-substitute . args)
- "Implement the build daemon's substituter protocol."
+(define-command (guix-substitute . args)
+ (category internal)
+ (synopsis "implement the build daemon's substituter protocol")
+
(define print-build-trace?
(match (or (find-daemon-option "untrusted-print-extended-build-trace")
(find-daemon-option "print-extended-build-trace"))
;; need an operating system configuration file.
(else (process-action command args opts))))
-(define (guix-system . args)
+(define-command (guix-system . args)
+ (synopsis "build and deploy full operating systems")
+
(define (parse-sub-command arg result)
;; Parse sub-command ARG and augment RESULT accordingly.
(if (assoc-ref result 'action)
;;; Entry point.
;;;
-(define (guix-time-machine . args)
+(define-command (guix-time-machine . args)
+ (synopsis "run commands from a different revision")
+
(with-error-handling
(with-git-error-handling
(let* ((opts (parse-args args))
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;;
;;; This file is part of GNU Guix.
%transformation-options
%standard-build-options)))
-(define (guix-upgrade . args)
+(define-command (guix-upgrade . args)
+ (synopsis "upgrade packages to their latest version")
+
(define (handle-argument arg result arg-handler)
;; Accept at most one non-option argument, and treat it as an upgrade
;; regexp.
;;; Entry point.
;;;
-(define (guix-weather . args)
+(define-command (guix-weather . args)
+ (synopsis "report on the availability of pre-built package binaries")
+
(define (package-list opts)
;; Return the package list specified by OPTS.
(let ((files (filter-map (match-lambda
;; 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)
(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)