module/scripts/help.scm

   1 ;;; Help --- Show help on guild commands
   2
   3 ;;;;    Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free
  17 ;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;;;; Boston, MA 02110-1301 USA
  19
  20 ;;; Commentary:
  21
  22 ;; Usage: help
  23 ;;
  24 ;; Show help for Guild scripts.
  25
  26 ;;; Code:
  27
  28 (define-module (scripts help)
  29   #:use-module (ice-9 format)
  30   #:use-module (ice-9 documentation)
  31   #:use-module ((srfi srfi-1) #:select (fold append-map))
  32   #:export (show-help show-summary show-usage main))
  33
  34 (define %summary "Show a brief help message.")
  35 (define %synopsis "help\nhelp --all\nhelp COMMAND")
  36 (define %help "
  37 Show help on guild commands.  With --all, show arcane incantations as
  38 well.  With COMMAND, show more detailed help for a particular command.
  39 ")
  40
  41 \f
  42 (define (directory-files dir)
  43   (if (and (file-exists? dir) (file-is-directory? dir))
  44       (let ((dir-stream (opendir dir)))
  45         (let loop ((new (readdir dir-stream))
  46                    (acc '()))
  47           (if (eof-object? new)
  48               (begin
  49                 (closedir dir-stream)
  50                 acc)
  51               (loop (readdir dir-stream)
  52                     (if (or (string=? "."  new)             ; ignore
  53                             (string=? ".." new))            ; ignore
  54                         acc
  55                         (cons new acc))))))
  56       '()))
  57
  58 (define (strip-extensions path)
  59   (or-map (lambda (ext)
  60             (and
  61              (string-suffix? ext path)
  62              ;; We really can't be adding e.g. ChangeLog-2008 to the set
  63              ;; of runnable scripts, just because "" is a valid
  64              ;; extension, by default.  So hack around that here.
  65              (not (string-null? ext))
  66              (substring path 0
  67                         (- (string-length path) (string-length ext)))))
  68           (append %load-compiled-extensions %load-extensions)))
  69
  70 (define (unique l)
  71   (cond ((null? l) l)
  72         ((null? (cdr l)) l)
  73         ((equal? (car l) (cadr l)) (unique (cdr l)))
  74         (else (cons (car l) (unique (cdr l))))))
  75
  76 (define (find-submodules head)
  77   (let ((shead (map symbol->string head)))
  78     (unique
  79      (sort
  80       (append-map (lambda (path)
  81                     (fold (lambda (x rest)
  82                             (let ((stripped (strip-extensions x)))
  83                               (if stripped (cons stripped rest) rest)))
  84                           '()
  85                           (directory-files
  86                            (fold (lambda (x y) (in-vicinity y x)) path shead))))
  87                   %load-path)
  88       string<?))))
  89
  90 (define (list-commands all?)
  91   (display "\
  92 Usage: guild COMMAND [ARGS]
  93 Run command-line scripts provided by GNU Guile and related programs.
  94
  95 Commands:
  96 ")
  97
  98   (for-each
  99    (lambda (name)
 100      (let* ((modname `(scripts ,(string->symbol name)))
 101             (mod (resolve-module modname #:ensure #f))
 102             (summary (and mod (and=> (module-variable mod '%summary)
 103                                      variable-ref))))
 104        (if (and mod
 105                 (or all?
 106                     (let ((v (module-variable mod '%include-in-guild-list)))
 107                       (if v (variable-ref v) #t))))
 108            (if summary
 109                (format #t "  ~A ~23t~a\n" name summary)
 110                (format #t "  ~A\n" name)))))
 111    (find-submodules '(scripts)))
 112   (format #t "
 113 For help on a specific command, try \"guild help COMMAND\".
 114
 115 Report guild bugs to ~a
 116 GNU Guile home page: <http://www.gnu.org/software/guile/>
 117 General help using GNU software: <http://www.gnu.org/gethelp/>
 118 For complete documentation, run: info guile 'Using Guile Tools'
 119 " %guile-bug-report-address))
 120
 121 (define (module-commentary mod)
 122   (file-commentary
 123    (%search-load-path (module-filename mod))))
 124
 125 (define (module-command-name mod)
 126   (symbol->string (car (last-pair (module-name mod)))))
 127
 128 (define* (show-usage mod #:optional (port (current-output-port)))
 129   (let ((usages (string-split
 130                  (let ((var (module-variable mod '%synopsis)))
 131                    (if var
 132                        (variable-ref var)
 133                        (string-append (module-command-name mod)
 134                                       " OPTION...")))
 135                  #\newline)))
 136     (display "Usage: guild " port)
 137     (display (car usages))
 138     (newline port)
 139     (for-each (lambda (u)
 140                 (display "       guild " port)
 141                 (display u port)
 142                 (newline port))
 143               (cdr usages))))
 144
 145 (define* (show-summary mod #:optional (port (current-output-port)))
 146   (let ((var (module-variable mod '%summary)))
 147     (if var
 148         (begin
 149           (display (variable-ref var) port)
 150           (newline port)))))
 151
 152 (define* (show-help mod #:optional (port (current-output-port)))
 153   (show-usage mod port)
 154   (show-summary mod port)
 155   (cond
 156    ((module-variable mod '%help)
 157     => (lambda (var)
 158          (display (variable-ref var) port)
 159          (newline port)))
 160    ((module-commentary mod)
 161     => (lambda (commentary)
 162          (newline port)
 163          (display commentary port)))
 164    (else
 165     (format #t "No documentation found for command \"~a\".\n"
 166             (module-command-name mod)))))
 167
 168 (define %mod (current-module))
 169 (define (main . args)
 170   (cond
 171    ((null? args)
 172     (list-commands #f))
 173    ((or (equal? args '("--all")) (equal? args '("-a")))
 174     (list-commands #t))
 175    ((and (null? (cdr args)) (not (string-prefix? "-" (car args))))
 176     ;; help for particular command
 177     (let ((name (car args)))
 178       (cond
 179        ((resolve-module `(scripts ,(string->symbol name)) #:ensure #f)
 180         => (lambda (mod)
 181              (show-help mod)
 182              (exit 0)))
 183        (else
 184         (format #t "No command named \"~a\".\n" name)
 185         (exit 1)))))
 186    (else
 187     (show-help %mod (current-error-port))
 188     (exit 1))))