Commit | Line | Data |
---|---|---|
f4a76a31 AW |
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) | |
4f0ea6e3 | 30 | #:use-module (ice-9 documentation) |
3cf634fa | 31 | #:use-module ((srfi srfi-1) #:select (fold append-map)) |
b8287e88 | 32 | #:export (show-help show-summary show-usage main)) |
f4a76a31 AW |
33 | |
34 | (define %summary "Show a brief help message.") | |
b8287e88 AW |
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 | ") | |
f4a76a31 AW |
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 | ||
4f0ea6e3 | 90 | (define (list-commands all?) |
f4a76a31 AW |
91 | (display "\ |
92 | Usage: guild COMMAND [ARGS] | |
0d2e3fc1 | 93 | Run command-line scripts provided by GNU Guile and related programs. |
f4a76a31 AW |
94 | |
95 | Commands: | |
96 | ") | |
97 | ||
4f0ea6e3 AW |
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))) | |
0d2e3fc1 | 112 | (format #t " |
4f0ea6e3 | 113 | For help on a specific command, try \"guild help COMMAND\". |
0d2e3fc1 LC |
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)) | |
4f0ea6e3 AW |
120 | |
121 | (define (module-commentary mod) | |
122 | (file-commentary | |
123 | (%search-load-path (module-filename mod)))) | |
124 | ||
b8287e88 AW |
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)) | |
4f0ea6e3 AW |
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)) | |
b8287e88 | 175 | ((and (null? (cdr args)) (not (string-prefix? "-" (car args)))) |
4f0ea6e3 | 176 | ;; help for particular command |
b8287e88 AW |
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))))) | |
4f0ea6e3 | 186 | (else |
b8287e88 | 187 | (show-help %mod (current-error-port)) |
4f0ea6e3 | 188 | (exit 1)))) |