Merge branch 'wip-lisp' into staging

1 files changed, 95 insertions, 36 deletions

diff --git a/guix/ui.scm b/guix/ui.scm
index 9513f42b93..115d9801b2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -15,6 +15,7 @@
 ;;; 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.
 ;;;
@@ -60,6 +61,7 @@
                         ;; 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)
@@ -545,8 +547,9 @@ There is NO WARRANTY, to the extent permitted by law.
 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)
@@ -1236,31 +1239,27 @@ separator between subsequent columns."
 (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
@@ -1283,8 +1282,8 @@ separator between subsequent columns."
       (((($ <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~%~}~%"
@@ -1301,9 +1300,8 @@ separator between subsequent columns."
       (((($ <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~%~}~%"
@@ -1992,6 +1990,44 @@ optionally contain a version number and an output name, as in these examples:
           (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
@@ -2003,28 +2039,51 @@ optionally contain a version number and an output name, as in these examples:
     (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)