add (scripts help)

* meta/guild.in (display-version): Use (ice-9 command-line)'s
  version-etc.
  (main): Dispatch --help to guild help.

* module/scripts/help.scm: New file, a copy of list.scm, but with a
  better name.

* module/Makefile.am: Add help.scm to the list.

* module/scripts/list.scm: Change to be an alias to "help".
  (list-scripts): Restore this API.

meta/guild.in

@@ -25,6 +25,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
 
 (define-module (guild)
   #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 command-line)
   #:autoload (ice-9 format) (format))
 
 ;; Hack to provide scripts with the bug-report address.
@@ -37,23 +38,11 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
   '((help (single-char #\h))
     (version (single-char #\v))))
 
-(define (display-help)
-  (display "\
-Usage: guild --version
-       guild --help
-       guild PROGRAM [ARGS]
-
-If PROGRAM is \"list\" or omitted, display available scripts, otherwise
-PROGRAM is run with ARGS.
-"))
-
 (define (display-version)
-  (format #t "guild (GNU Guile ~A) ~A
+  (version-etc "GNU Guile"
-Copyright (C) 2010 Free Software Foundation, Inc.
+               (effective-version)
-License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
+               #:command-name "guild"
-This is free software: you are free to change and redistribute it.
+               #:license *LGPLv3+*))
-There is NO WARRANTY, to the extent permitted by law.
-" (version) (effective-version)))
 
 (define (find-script s)
   (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
@@ -62,27 +51,24 @@ There is NO WARRANTY, to the extent permitted by law.
   (if (defined? 'setlocale)
       (setlocale LC_ALL ""))
 
-  (let ((options (getopt-long args *option-grammar*
+  (let* ((options (getopt-long args *option-grammar*
-                              #:stop-at-first-non-option #t)))
+                               #:stop-at-first-non-option #t))
+         (args (option-ref options '() '())))
     (cond
      ((option-ref options 'help #f)
-      (display-help)
+      (apply (module-ref (resolve-module '(scripts help)) 'main) args)
       (exit 0))
      ((option-ref options 'version #f)
       (display-version)
       (exit 0))
+     ((find-script (if (null? args) "help" (car args)))
+      => (lambda (mod)
+           (exit (apply (module-ref mod 'main) (if (null? args)
+                                                   '()
+                                                   (cdr args))))))
      (else
-      (let ((args (option-ref options '() '())))
+      (format (current-error-port)
-        (cond ((find-script (if (null? args)
+              "guild: unknown script ~s~%" (car args))
-                                "list"
+      (format (current-error-port)
-                                (car args)))
+              "Try `guild help' for more information.~%")
-               => (lambda (mod)
+      (exit 1)))))
-                    (exit (apply (module-ref mod 'main) (if (null? args)
-                                                            '()
-                                                            (cdr args))))))
-              (else
-               (format (current-error-port)
-                       "guild: unknown script ~s~%" (car args))
-               (format (current-error-port)
-                       "Try `guild --help' for more information.~%")
-               (exit 1))))))))

module/Makefile.am

@@ -153,6 +153,7 @@ SCRIPTS_SOURCES =				\
   scripts/doc-snarf.scm				\
   scripts/frisk.scm				\
   scripts/generate-autoload.scm			\
+  scripts/help.scm				\
   scripts/lint.scm				\
   scripts/list.scm				\
   scripts/punify.scm				\

module/scripts/help.scm

@@ -0,0 +1,109 @@
+;;; Help --- Show help on guild commands
+
+;;;; 	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: help
+;;
+;; Show help for Guild scripts.
+
+;;; Code:
+
+(define-module (scripts help)
+  #:use-module (ice-9 format)
+  #:use-module ((srfi srfi-1) #:select (fold append-map)))
+
+(define %summary "Show a brief help message.")
+
+
+(define (directory-files dir)
+  (if (and (file-exists? dir) (file-is-directory? dir))
+      (let ((dir-stream (opendir dir)))
+        (let loop ((new (readdir dir-stream))
+                   (acc '()))
+          (if (eof-object? new)
+              (begin
+                (closedir dir-stream)
+                acc)
+              (loop (readdir dir-stream)
+                    (if (or (string=? "."  new)             ; ignore
+                            (string=? ".." new))            ; ignore
+                        acc
+                        (cons new acc))))))
+      '()))
+
+(define (strip-extensions path)
+  (or-map (lambda (ext)
+            (and
+             (string-suffix? ext path)
+             ;; We really can't be adding e.g. ChangeLog-2008 to the set
+             ;; of runnable scripts, just because "" is a valid
+             ;; extension, by default.  So hack around that here.
+             (not (string-null? ext))
+             (substring path 0
+                        (- (string-length path) (string-length ext)))))
+          (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+  (cond ((null? l) l)
+        ((null? (cdr l)) l)
+        ((equal? (car l) (cadr l)) (unique (cdr l)))
+        (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+  (let ((shead (map symbol->string head)))
+    (unique
+     (sort
+      (append-map (lambda (path)
+                    (fold (lambda (x rest)
+                            (let ((stripped (strip-extensions x)))
+                              (if stripped (cons stripped rest) rest)))
+                          '()
+                          (directory-files
+                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
+                  %load-path)
+      string<?))))
+
+(define (main . args)
+  (display "\
+Usage: guild COMMAND [ARGS]
+
+  guild runs command-line scripts provided by GNU Guile and related
+  programs.  See \"Using Guile Tools\" in the Guile manual, for more
+  information.
+
+Commands:
+")
+
+  (let ((all? (or (equal? args '("--all"))
+                  (equal? args '("-a")))))
+    (for-each
+     (lambda (name)
+       (let* ((modname `(scripts ,(string->symbol name)))
+              (mod (resolve-module modname #:ensure #f))
+              (summary (and mod (and=> (module-variable mod '%summary)
+                                       variable-ref))))
+         (if (and mod
+                  (or all?
+                      (let ((v (module-variable mod '%include-in-guild-list)))
+                        (if v (variable-ref v) #t))))
+             (if summary
+                 (format #t "  ~A ~23t~a\n" name summary)
+                 (format #t "  ~A\n" name)))))
+     (find-submodules '(scripts)))))

module/scripts/list.scm

@@ -26,12 +26,10 @@
 ;;; Code:
 
 (define-module (scripts list)
-  #:use-module (ice-9 format)
-  #:use-module ((srfi srfi-1) #:select (fold append-map))
   #:export (list-scripts))
 
 (define %include-in-guild-list #f)
-(define %summary "List available guild commands.")
+(define %summary "An alias for \"help\".")
 
 
 (define (directory-files dir)
@@ -82,36 +80,11 @@
                   %load-path)
       string<?))))
 
+(define (list-scripts . args)
+  (for-each (lambda (x)
+              ;; would be nice to show a summary.
+              (format #t "~A\n" x))
+            (find-submodules '(scripts))))
+
 (define (main . args)
-  (display "\
+  (apply (@@ (scripts help) main) args))
-Usage: guild COMMAND [ARGS]
-
-  guild runs command-line scripts provided by GNU Guile and related
-  programs.  See \"Using Guile Tools\" in the Guile manual, for more
-  information.
-
-Commands:
-")
-
-  (let ((all? (or (equal? args '("--all"))
-                  (equal? args '("-a")))))
-    (for-each
-     (lambda (name)
-       (let* ((modname `(scripts ,(string->symbol name)))
-              (mod (resolve-module modname #:ensure #f))
-              (summary (and mod (and=> (module-variable mod '%summary)
-                                       variable-ref))))
-         (if (and mod
-                  (or all?
-                      (let ((v (module-variable mod '%include-in-guild-list)))
-                        (if v (variable-ref v) #t))))
-             (if summary
-                 (format #t "  ~A ~23t~a\n" name summary)
-                 (format #t "  ~A\n" name)))))
-     (find-submodules '(scripts))))
-
-  (display "\
-
-If COMMAND is \"list\" or omitted, display available scripts, otherwise
-COMMAND is run with ARGS.
-"))