X-Git-Url: https://git.jsancho.org/?p=guile-click.git;a=blobdiff_plain;f=click%2Fhelp.scm;fp=click%2Fhelp.scm;h=9d0c5cc05e9134d41cf7f0f0acb12fc138d35b09;hp=f397031ab1cdae525403b2ede30e4084e610222a;hb=84da61950d4a4038f76fdb9f66e0bbbb71f75385;hpb=ebf74b7c3fda8ead57a398bb6a1555067150d06f

diff --git a/click/help.scm b/click/help.scm
index f397031..9d0c5cc 100644
--- a/click/help.scm
+++ b/click/help.scm
@@ -19,6 +19,7 @@
 
 (define-module (click help)
   #:use-module (ice-9 format)
+  #:use-module (click command)
   #:use-module (click util)
   #:export (display-error
             display-help))
@@ -29,41 +30,39 @@
   (assoc-ref (option-type option) 'description))
 
 
-(define (get-title target)
+(define* (get-help-text procedure #:optional (help-text ""))
   "Return the title for the help message"
-  (cond ((procedure? target)
-         (procedure-documentation target))
+  (cond ((> (string-length help-text) 0)
+         help-text)
+        ((procedure? procedure)
+         (let ((doc-text (procedure-documentation procedure)))
+           (and (string? doc-text)
+                (> (string-length doc-text) 0)
+                doc-text)))
         (else
-         target)))
+         help-text)))
 
 
-(define* (display-help program-name target option-spec #:optional (commands '()))
-  (format #t "Usage: ~a [OPTIONS]
+(define (get-help-text command)
+  "Return the title for the help message"
+  (let ((procedure (command-procedure command))
+        (help-text (command-help-text command)))
+    (cond ((> (string-length help-text) 0)
+           help-text)
+          ((procedure? procedure)
+           (let ((doc-text (procedure-documentation procedure)))
+             (and (string? doc-text)
+                  (> (string-length doc-text) 0)
+                  doc-text)))
+          (else
+           help-text))))
+
 
-  ~a
-
-Options:
-" program-name (get-title target))
-
-  (let* ((options (map (lambda (option)
-                         (cons (format #f
-                                       "--~a~a~a"
-                                       (car option)
-                                       (let ((single-char
-                                              (option-property option 'single-char)))
-                                         (if single-char
-                                             (format #f ", -~a" single-char)
-                                             ""))
-                                       (let ((value
-                                              (not (option-property option 'flag))))
-                                         (if value
-                                             (format #f " ~a" (get-type-description option))
-                                             "")))
-                               (option-property option 'help "")))
-                       option-spec))
-         (sep (+ 2 (apply max (map (lambda (option)
-                                     (string-length (car option)))
-                                   options)))))
+(define (display-options options)
+  "Display options in tabular way"
+  (let ((sep (+ 2 (apply max (map (lambda (option)
+                                    (string-length (car option)))
+                                  options)))))
     (for-each (lambda (option)
                 (format #t
                         "  ~a~v_~a~%"
@@ -73,6 +72,50 @@ Options:
               options)))
 
 
+(define* (display-help program-name command)
+  "Display help message"
+
+  ;; Usage
+  (format #t "Usage: ~a [OPTIONS]" program-name)
+  (when (group? command)
+    (format #t " COMMAND [ARGS]..."))
+  (format #t "~%~%")
+
+  ;; Title
+  (let ((title (get-help-text command)))
+    (when title
+      (format #t "  ~a~%~%" title)))
+
+  ;; Options
+  (format #t "Options:~%")
+  (let ((options (map (lambda (option)
+                        (cons (format #f
+                                      "--~a~a~a"
+                                      (car option)
+                                      (let ((single-char
+                                             (option-property option 'single-char)))
+                                        (if single-char
+                                            (format #f ", -~a" single-char)
+                                            ""))
+                                      (let ((value
+                                             (not (option-property option 'flag))))
+                                        (if value
+                                            (format #f " ~a" (get-type-description option))
+                                            "")))
+                              (option-property option 'help "")))
+                      (command-option-spec command))))
+    (display-options options))
+
+  ;; Commands
+  (when (group? command)
+    (format #t "~%Commands:~%")
+    (let ((options (map (lambda (command)
+                          (cons (or (command-name command) "")
+                                (or (get-help-text command) "")))
+                        (command-commands command))))
+      (display-options options))))
+
+
 (define (display-error wrong-option)
   (format #t "Usage: ~a [OPTIONS]
 Try '~a --help' for help.