summaryrefslogtreecommitdiff
path: root/module/scripts/help.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/scripts/help.scm')
-rw-r--r--module/scripts/help.scm188
1 files changed, 188 insertions, 0 deletions
diff --git a/module/scripts/help.scm b/module/scripts/help.scm
new file mode 100644
index 000000000..34400db3a
--- /dev/null
+++ b/module/scripts/help.scm
@@ -0,0 +1,188 @@
+;;; 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 (ice-9 documentation)
+ #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:export (show-help show-summary show-usage main))
+
+(define %summary "Show a brief help message.")
+(define %synopsis "help\nhelp --all\nhelp COMMAND")
+(define %help "
+Show help on guild commands. With --all, show arcane incantations as
+well. With COMMAND, show more detailed help for a particular command.
+")
+
+
+(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 (list-commands all?)
+ (display "\
+Usage: guild COMMAND [ARGS]
+Run command-line scripts provided by GNU Guile and related programs.
+
+Commands:
+")
+
+ (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)))
+ (format #t "
+For help on a specific command, try \"guild help COMMAND\".
+
+Report guild bugs to ~a
+GNU Guile home page: <http://www.gnu.org/software/guile/>
+General help using GNU software: <http://www.gnu.org/gethelp/>
+For complete documentation, run: info '(guile)Using Guile Tools'
+" %guile-bug-report-address))
+
+(define (module-commentary mod)
+ (file-commentary
+ (%search-load-path (module-filename mod))))
+
+(define (module-command-name mod)
+ (symbol->string (car (last-pair (module-name mod)))))
+
+(define* (show-usage mod #:optional (port (current-output-port)))
+ (let ((usages (string-split
+ (let ((var (module-variable mod '%synopsis)))
+ (if var
+ (variable-ref var)
+ (string-append (module-command-name mod)
+ " OPTION...")))
+ #\newline)))
+ (display "Usage: guild " port)
+ (display (car usages))
+ (newline port)
+ (for-each (lambda (u)
+ (display " guild " port)
+ (display u port)
+ (newline port))
+ (cdr usages))))
+
+(define* (show-summary mod #:optional (port (current-output-port)))
+ (let ((var (module-variable mod '%summary)))
+ (if var
+ (begin
+ (display (variable-ref var) port)
+ (newline port)))))
+
+(define* (show-help mod #:optional (port (current-output-port)))
+ (show-usage mod port)
+ (show-summary mod port)
+ (cond
+ ((module-variable mod '%help)
+ => (lambda (var)
+ (display (variable-ref var) port)
+ (newline port)))
+ ((module-commentary mod)
+ => (lambda (commentary)
+ (newline port)
+ (display commentary port)))
+ (else
+ (format #t "No documentation found for command \"~a\".\n"
+ (module-command-name mod)))))
+
+(define %mod (current-module))
+(define (main . args)
+ (cond
+ ((null? args)
+ (list-commands #f))
+ ((or (equal? args '("--all")) (equal? args '("-a")))
+ (list-commands #t))
+ ((and (null? (cdr args)) (not (string-prefix? "-" (car args))))
+ ;; help for particular command
+ (let ((name (car args)))
+ (cond
+ ((resolve-module `(scripts ,(string->symbol name)) #:ensure #f)
+ => (lambda (mod)
+ (show-help mod)
+ (exit 0)))
+ (else
+ (format #t "No command named \"~a\".\n" name)
+ (exit 1)))))
+ (else
+ (show-help %mod (current-error-port))
+ (exit 1))))