Commit | Line | Data |
---|---|---|
a8215aed | 1 | ;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011, |
f41accb9 | 2 | ;;;; 2012, 2013 Free Software Foundation, Inc. |
7bb1bfc2 | 3 | ;;;; |
73be1d9e MV |
4 | ;;;; This library is free software; you can redistribute it and/or |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
8 | ;;;; |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
0e81dabd | 10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 17 | ;;;; |
0e81dabd MD |
18 | \f |
19 | ||
bbefd480 | 20 | (define-module (ice-9 session) |
ac16263b AW |
21 | #:use-module (ice-9 documentation) |
22 | #:use-module (ice-9 regex) | |
23 | #:use-module (ice-9 rdelim) | |
a8215aed | 24 | #:use-module (ice-9 match) |
ac16263b AW |
25 | #:export (help |
26 | add-value-help-handler! remove-value-help-handler! | |
27 | add-name-help-handler! remove-name-help-handler! | |
28 | apropos-hook | |
29 | apropos apropos-internal apropos-fold apropos-fold-accessible | |
30 | apropos-fold-exported apropos-fold-all source arity | |
31 | procedure-arguments | |
32 | module-commentary)) | |
0e81dabd MD |
33 | |
34 | \f | |
35 | ||
53d81399 AW |
36 | (define *value-help-handlers* |
37 | `(,(lambda (name value) | |
38 | (object-documentation value)))) | |
4f7a0504 AW |
39 | |
40 | (define (add-value-help-handler! proc) | |
41 | "Adds a handler for performing `help' on a value. | |
42 | ||
43 | `proc' will be called as (PROC NAME VALUE). `proc' should return #t to | |
44 | indicate that it has performed help, a string to override the default | |
45 | object documentation, or #f to try the other handlers, potentially | |
46 | falling back on the normal behavior for `help'." | |
47 | (set! *value-help-handlers* (cons proc *value-help-handlers*))) | |
48 | ||
49 | (define (remove-value-help-handler! proc) | |
53d81399 | 50 | "Removes a handler for performing `help' on a value." |
4f7a0504 AW |
51 | (set! *value-help-handlers* (delete! proc *value-help-handlers*))) |
52 | ||
53 | (define (try-value-help name value) | |
54 | (or-map (lambda (proc) (proc name value)) *value-help-handlers*)) | |
55 | ||
56 | ||
57 | (define *name-help-handlers* '()) | |
58 | ||
59 | (define (add-name-help-handler! proc) | |
60 | "Adds a handler for performing `help' on a name. | |
61 | ||
62 | `proc' will be called with the unevaluated name as its argument. That is | |
63 | to say, when the user calls `(help FOO)', the name is FOO, exactly as | |
64 | the user types it. | |
65 | ||
53d81399 AW |
66 | `proc' should return #t to indicate that it has performed help, a string |
67 | to override the default object documentation, or #f to try the other | |
68 | handlers, potentially falling back on the normal behavior for `help'." | |
4f7a0504 AW |
69 | (set! *name-help-handlers* (cons proc *name-help-handlers*))) |
70 | ||
71 | (define (remove-name-help-handler! proc) | |
53d81399 | 72 | "Removes a handler for performing `help' on a name." |
4f7a0504 AW |
73 | (set! *name-help-handlers* (delete! proc *name-help-handlers*))) |
74 | ||
75 | (define (try-name-help name) | |
76 | (or-map (lambda (proc) (proc name)) *name-help-handlers*)) | |
77 | ||
78 | ||
13ae9151 MD |
79 | ;;; Documentation |
80 | ;;; | |
99b1dd09 AW |
81 | (define-macro (help . exp) |
82 | "(help [NAME]) | |
13ae9151 | 83 | Prints useful information. Try `(help)'." |
99b1dd09 | 84 | (cond ((not (= (length exp) 1)) |
2588eccd AW |
85 | (help-usage) |
86 | '(begin)) | |
99b1dd09 AW |
87 | ((not (provided? 'regex)) |
88 | (display "`help' depends on the `regex' feature. | |
2588eccd AW |
89 | You don't seem to have regular expressions installed.\n") |
90 | '(begin)) | |
99b1dd09 AW |
91 | (else |
92 | (let ((name (car exp)) | |
93 | (not-found (lambda (type x) | |
94 | (simple-format #t "No ~A found for ~A\n" | |
95 | type x)))) | |
96 | (cond | |
97 | ||
df22662f AW |
98 | ;; User-specified |
99 | ((try-name-help name) | |
100 | => (lambda (x) (if (not (eq? x #t)) (display x)))) | |
101 | ||
99b1dd09 AW |
102 | ;; SYMBOL |
103 | ((symbol? name) | |
104 | (help-doc name | |
105 | (simple-format | |
106 | #f "^~A$" | |
107 | (regexp-quote (symbol->string name))))) | |
108 | ||
109 | ;; "STRING" | |
110 | ((string? name) | |
111 | (help-doc name name)) | |
112 | ||
113 | ;; (unquote SYMBOL) | |
114 | ((and (list? name) | |
115 | (= (length name) 2) | |
116 | (eq? (car name) 'unquote)) | |
df22662f | 117 | (let ((doc (try-value-help (cadr name) |
84012ef4 LC |
118 | (module-ref (current-module) |
119 | (cadr name))))) | |
df22662f AW |
120 | (cond ((not doc) (not-found 'documentation (cadr name))) |
121 | ((eq? doc #t)) ;; pass | |
122 | (else (write-line doc))))) | |
99b1dd09 AW |
123 | |
124 | ;; (quote SYMBOL) | |
125 | ((and (list? name) | |
126 | (= (length name) 2) | |
127 | (eq? (car name) 'quote) | |
128 | (symbol? (cadr name))) | |
129 | (cond ((search-documentation-files (cadr name)) | |
130 | => write-line) | |
131 | (else (not-found 'documentation (cadr name))))) | |
132 | ||
133 | ;; (SYM1 SYM2 ...) | |
134 | ((and (list? name) | |
135 | (and-map symbol? name) | |
136 | (not (null? name)) | |
137 | (not (eq? (car name) 'quote))) | |
138 | (cond ((module-commentary name) | |
139 | => (lambda (doc) | |
140 | (display name) (write-line " commentary:") | |
141 | (write-line doc))) | |
142 | (else (not-found 'commentary name)))) | |
143 | ||
144 | ;; unrecognized | |
de25f281 | 145 | (else |
99b1dd09 AW |
146 | (help-usage))) |
147 | '(begin))))) | |
13ae9151 | 148 | |
7bb1bfc2 TTN |
149 | (define (module-filename name) ; fixme: better way? / done elsewhere? |
150 | (let* ((name (map symbol->string name)) | |
151 | (reverse-name (reverse name)) | |
152 | (leaf (car reverse-name)) | |
153 | (dir-hint-module-name (reverse (cdr reverse-name))) | |
154 | (dir-hint (apply string-append | |
155 | (map (lambda (elt) | |
156 | (string-append elt "/")) | |
157 | dir-hint-module-name)))) | |
158 | (%search-load-path (in-vicinity dir-hint leaf)))) | |
159 | ||
160 | (define (module-commentary name) | |
161 | (cond ((module-filename name) => file-commentary) | |
162 | (else #f))) | |
163 | ||
3bdca000 MD |
164 | (define (help-doc term regexp) |
165 | (let ((entries (apropos-fold (lambda (module name object data) | |
166 | (cons (list module | |
167 | name | |
53d81399 | 168 | (try-value-help name object) |
314b8716 | 169 | (cond ((procedure? object) |
db611983 | 170 | "a procedure") |
db611983 NJ |
171 | (else |
172 | "an object"))) | |
3bdca000 MD |
173 | data)) |
174 | '() | |
175 | regexp | |
176 | apropos-fold-exported)) | |
177 | (module car) | |
178 | (name cadr) | |
db611983 NJ |
179 | (doc caddr) |
180 | (type cadddr)) | |
de25f281 TTN |
181 | (cond ((not (null? entries)) |
182 | (let ((first? #t) | |
183 | (undocumented-entries '()) | |
184 | (documented-entries '()) | |
185 | (documentations '())) | |
186 | ||
187 | (for-each (lambda (entry) | |
188 | (let ((entry-summary (simple-format | |
189 | #f "~S: ~S\n" | |
190 | (module-name (module entry)) | |
191 | (name entry)))) | |
192 | (if (doc entry) | |
193 | (begin | |
194 | (set! documented-entries | |
195 | (cons entry-summary documented-entries)) | |
196 | ;; *fixme*: Use `describe' when we have GOOPS? | |
197 | (set! documentations | |
198 | (cons (simple-format | |
199 | #f "`~S' is ~A in the ~S module.\n\n~A\n" | |
200 | (name entry) | |
201 | (type entry) | |
202 | (module-name (module entry)) | |
203 | (doc entry)) | |
204 | documentations))) | |
205 | (set! undocumented-entries | |
206 | (cons entry-summary | |
207 | undocumented-entries))))) | |
208 | entries) | |
209 | ||
210 | (if (and (not (null? documented-entries)) | |
211 | (or (> (length documented-entries) 1) | |
212 | (not (null? undocumented-entries)))) | |
213 | (begin | |
214 | (display "Documentation found for:\n") | |
215 | (for-each (lambda (entry) (display entry)) | |
216 | documented-entries) | |
217 | (set! first? #f))) | |
218 | ||
219 | (for-each (lambda (entry) | |
220 | (if first? | |
221 | (set! first? #f) | |
222 | (newline)) | |
223 | (display entry)) | |
224 | documentations) | |
225 | ||
226 | (if (not (null? undocumented-entries)) | |
227 | (begin | |
228 | (if first? | |
229 | (set! first? #f) | |
230 | (newline)) | |
231 | (display "No documentation found for:\n") | |
232 | (for-each (lambda (entry) (display entry)) | |
233 | undocumented-entries))))) | |
234 | ((search-documentation-files term) | |
235 | => (lambda (doc) | |
236 | (write-line "Documentation from file:") | |
237 | (write-line doc))) | |
238 | (else | |
239 | ;; no matches | |
240 | (display "Did not find any object ") | |
241 | (simple-format #t | |
242 | (if (symbol? term) | |
243 | "named `~A'\n" | |
244 | "matching regexp \"~A\"\n") | |
245 | term))))) | |
3bdca000 | 246 | |
13ae9151 | 247 | (define (help-usage) |
3bdca000 MD |
248 | (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) |
249 | (help REGEXP) ditto for objects with names matching REGEXP (a string) | |
1de3b33b | 250 | (help 'NAME) gives documentation for NAME, even if it is not an object |
d1c50f73 | 251 | (help ,EXPR) gives documentation for object returned by EXPR |
8bbe4c82 | 252 | (help (my module)) gives module commentary for `(my module)' |
13ae9151 MD |
253 | (help) gives this text |
254 | ||
3bdca000 MD |
255 | `help' searches among bindings exported from loaded modules, while |
256 | `apropos' searches among bindings visible from the \"current\" module. | |
257 | ||
2f52380c MD |
258 | Examples: (help help) |
259 | (help cons) | |
3bdca000 | 260 | (help \"output-string\") |
13ae9151 MD |
261 | |
262 | Other useful sources of helpful information: | |
263 | ||
264 | (apropos STRING) | |
265 | (arity PROCEDURE) | |
266 | (name PROCEDURE-OR-MACRO) | |
267 | (source PROCEDURE-OR-MACRO) | |
268 | ||
269 | Tools: | |
270 | ||
2f52380c MD |
271 | (backtrace) ;show backtrace from last error |
272 | (debug) ;enter the debugger | |
273 | (trace [PROCEDURE]) ;trace procedure (no arg => show) | |
274 | (untrace [PROCEDURE]) ;untrace (no arg => untrace all) | |
13ae9151 MD |
275 | |
276 | (OPTIONSET-options 'full) ;display option information | |
277 | (OPTIONSET-enable 'OPTION) | |
278 | (OPTIONSET-disable 'OPTION) | |
279 | (OPTIONSET-set! OPTION VALUE) | |
280 | ||
281 | where OPTIONSET is one of debug, read, eval, print | |
282 | ||
283 | ")) | |
284 | ||
0e81dabd MD |
285 | ;;; {Apropos} |
286 | ;;; | |
287 | ;;; Author: Roland Orre <orre@nada.kth.se> | |
288 | ;;; | |
289 | ||
ac16263b AW |
290 | ;; Two arguments: the module, and the pattern, as a string. |
291 | ;; | |
292 | (define apropos-hook (make-hook 2)) | |
293 | ||
1a179b03 | 294 | (define (apropos rgx . options) |
0e81dabd | 295 | "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" |
ac16263b | 296 | (run-hook apropos-hook (current-module) rgx) |
0e81dabd MD |
297 | (if (zero? (string-length rgx)) |
298 | "Empty string not allowed" | |
4f161c5c | 299 | (let* ((match (make-regexp rgx)) |
3742da68 | 300 | (uses (module-uses (current-module))) |
0e81dabd | 301 | (modules (cons (current-module) |
3742da68 MD |
302 | (if (and (not (null? uses)) |
303 | (eq? (module-name (car uses)) | |
304 | 'duplicates)) | |
305 | (cdr uses) | |
306 | uses))) | |
0e81dabd MD |
307 | (separator #\tab) |
308 | (shadow (member 'shadow options)) | |
309 | (value (member 'value options))) | |
310 | (cond ((member 'full options) | |
311 | (set! shadow #t) | |
312 | (set! value #t))) | |
313 | (for-each | |
314 | (lambda (module) | |
296ff5e7 MV |
315 | (let* ((name (module-name module)) |
316 | (obarray (module-obarray module))) | |
317 | ;; XXX - should use hash-fold here | |
1798b73d MD |
318 | (hash-for-each |
319 | (lambda (symbol variable) | |
320 | (cond ((regexp-exec match (symbol->string symbol)) | |
321 | (display name) | |
322 | (display ": ") | |
323 | (display symbol) | |
324 | (cond ((variable-bound? variable) | |
325 | (let ((val (variable-ref variable))) | |
326 | (cond ((or (procedure? val) value) | |
327 | (display separator) | |
328 | (display val))))) | |
329 | (else | |
330 | (display separator) | |
331 | (display "(unbound)"))) | |
332 | (if (and shadow | |
333 | (not (eq? (module-ref module symbol) | |
334 | (module-ref (current-module) symbol)))) | |
335 | (display " shadowed")) | |
336 | (newline)))) | |
10764e3c | 337 | obarray))) |
0e81dabd | 338 | modules)))) |
68aed3ea | 339 | |
1a179b03 | 340 | (define (apropos-internal rgx) |
68aed3ea | 341 | "Return a list of accessible variable names." |
3bdca000 MD |
342 | (apropos-fold (lambda (module name var data) |
343 | (cons name data)) | |
344 | '() | |
345 | rgx | |
346 | (apropos-fold-accessible (current-module)))) | |
347 | ||
1a179b03 | 348 | (define (apropos-fold proc init rgx folder) |
3bdca000 MD |
349 | "Folds PROCEDURE over bindings matching third arg REGEXP. |
350 | ||
351 | Result is | |
352 | ||
353 | (PROCEDURE MODULE1 NAME1 VALUE1 | |
354 | (PROCEDURE MODULE2 NAME2 VALUE2 | |
355 | ... | |
356 | (PROCEDURE MODULEn NAMEn VALUEn INIT))) | |
357 | ||
358 | where INIT is the second arg to `apropos-fold'. | |
359 | ||
360 | Fourth arg FOLDER is one of | |
361 | ||
362 | (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE | |
363 | apropos-fold-exported ;fold over all exported bindings | |
364 | apropos-fold-all ;fold over all bindings" | |
ac16263b | 365 | (run-hook apropos-hook (current-module) rgx) |
3bdca000 | 366 | (let ((match (make-regexp rgx)) |
2dd7d8ce | 367 | (recorded (make-hash-table))) |
3bdca000 MD |
368 | (let ((fold-module |
369 | (lambda (module data) | |
370 | (let* ((obarray-filter | |
371 | (lambda (name val data) | |
4adc3028 | 372 | (if (and (regexp-exec match (symbol->string name)) |
3bdca000 MD |
373 | (not (hashq-get-handle recorded name))) |
374 | (begin | |
375 | (hashq-set! recorded name #t) | |
376 | (proc module name val data)) | |
377 | data))) | |
378 | (module-filter | |
379 | (lambda (name var data) | |
aef9dd65 MV |
380 | (if (variable-bound? var) |
381 | (obarray-filter name (variable-ref var) data) | |
382 | data)))) | |
296ff5e7 | 383 | (cond (module (hash-fold module-filter |
3bdca000 MD |
384 | data |
385 | (module-obarray module))) | |
386 | (else data)))))) | |
387 | (folder fold-module init)))) | |
388 | ||
389 | (define (make-fold-modules init-thunk traverse extract) | |
390 | "Return procedure capable of traversing a forest of modules. | |
391 | The forest traversed is the image of the forest generated by root | |
392 | modules returned by INIT-THUNK and the generator TRAVERSE. | |
393 | It is an image under the mapping EXTRACT." | |
394 | (lambda (fold-module init) | |
9aec4751 MD |
395 | (let* ((table (make-hash-table 31)) |
396 | (first? (lambda (obj) | |
8d627248 MD |
397 | (let* ((handle (hash-create-handle! table obj #t)) |
398 | (first? (cdr handle))) | |
399 | (set-cdr! handle #f) | |
400 | first?)))) | |
9aec4751 MD |
401 | (let rec ((data init) |
402 | (modules (init-thunk))) | |
403 | (do ((modules modules (cdr modules)) | |
404 | (data data (if (first? (car modules)) | |
405 | (rec (fold-module (extract (car modules)) data) | |
406 | (traverse (car modules))) | |
407 | data))) | |
408 | ((null? modules) data)))))) | |
3bdca000 | 409 | |
1a179b03 | 410 | (define (apropos-fold-accessible module) |
3bdca000 MD |
411 | (make-fold-modules (lambda () (list module)) |
412 | module-uses | |
de25f281 | 413 | identity)) |
3bdca000 MD |
414 | |
415 | (define (root-modules) | |
aa26a6d2 | 416 | (submodules (resolve-module '() #f))) |
3bdca000 | 417 | |
a148c752 JOR |
418 | (define (submodules mod) |
419 | (hash-map->list (lambda (k v) v) (module-submodules mod))) | |
3bdca000 | 420 | |
1a179b03 | 421 | (define apropos-fold-exported |
3bdca000 MD |
422 | (make-fold-modules root-modules submodules module-public-interface)) |
423 | ||
1a179b03 | 424 | (define apropos-fold-all |
de25f281 | 425 | (make-fold-modules root-modules submodules identity)) |
7cfae7e6 | 426 | |
1a179b03 | 427 | (define (source obj) |
7cfae7e6 MD |
428 | (cond ((procedure? obj) (procedure-source obj)) |
429 | ((macro? obj) (procedure-source (macro-transformer obj))) | |
430 | (else #f))) | |
4a9f464e | 431 | |
1a179b03 | 432 | (define (arity obj) |
c7bb434f TTN |
433 | (define (display-arg-list arg-list) |
434 | (display #\`) | |
435 | (display (car arg-list)) | |
436 | (let loop ((ls (cdr arg-list))) | |
437 | (cond ((null? ls) | |
438 | (display #\')) | |
439 | ((not (pair? ls)) | |
440 | (display "', the rest in `") | |
441 | (display ls) | |
442 | (display #\')) | |
443 | (else | |
444 | (if (pair? (cdr ls)) | |
445 | (display "', `") | |
446 | (display "' and `")) | |
447 | (display (car ls)) | |
448 | (loop (cdr ls)))))) | |
449 | (define (display-arg-list/summary arg-list type) | |
450 | (let ((len (length arg-list))) | |
451 | (display len) | |
452 | (display " ") | |
453 | (display type) | |
454 | (if (> len 1) | |
455 | (display " arguments: ") | |
456 | (display " argument: ")) | |
457 | (display-arg-list arg-list))) | |
458 | (cond | |
459 | ((procedure-property obj 'arglist) | |
460 | => (lambda (arglist) | |
461 | (let ((required-args (car arglist)) | |
462 | (optional-args (cadr arglist)) | |
463 | (keyword-args (caddr arglist)) | |
464 | (allow-other-keys? (cadddr arglist)) | |
465 | (rest-arg (car (cddddr arglist))) | |
466 | (need-punctuation #f)) | |
467 | (cond ((not (null? required-args)) | |
468 | (display-arg-list/summary required-args "required") | |
469 | (set! need-punctuation #t))) | |
470 | (cond ((not (null? optional-args)) | |
471 | (if need-punctuation (display ", ")) | |
472 | (display-arg-list/summary optional-args "optional") | |
473 | (set! need-punctuation #t))) | |
474 | (cond ((not (null? keyword-args)) | |
475 | (if need-punctuation (display ", ")) | |
476 | (display-arg-list/summary keyword-args "keyword") | |
477 | (set! need-punctuation #t))) | |
478 | (cond (allow-other-keys? | |
479 | (if need-punctuation (display ", ")) | |
480 | (display "other keywords allowed") | |
481 | (set! need-punctuation #t))) | |
482 | (cond (rest-arg | |
483 | (if need-punctuation (display ", ")) | |
484 | (display "the rest in `") | |
485 | (display rest-arg) | |
486 | (display "'")))))) | |
487 | (else | |
3fc7e2c1 | 488 | (let ((arity (procedure-minimum-arity obj))) |
c7bb434f TTN |
489 | (display (car arity)) |
490 | (cond ((caddr arity) | |
491 | (display " or more")) | |
492 | ((not (zero? (cadr arity))) | |
493 | (display " required and ") | |
494 | (display (cadr arity)) | |
495 | (display " optional"))) | |
496 | (if (and (not (caddr arity)) | |
497 | (= (car arity) 1) | |
498 | (<= (cadr arity) 1)) | |
499 | (display " argument") | |
314b8716 | 500 | (display " arguments"))))) |
c7bb434f | 501 | (display ".\n")) |
6ae34994 | 502 | |
0704c813 AW |
503 | |
504 | (define (procedure-arguments proc) | |
505 | "Return an alist describing the arguments that `proc' accepts, or `#f' | |
506 | if the information cannot be obtained. | |
507 | ||
508 | The alist keys that are currently defined are `required', `optional', | |
a8215aed | 509 | `keyword', `allow-other-keys?', and `rest'." |
0704c813 AW |
510 | (cond |
511 | ((procedure-property proc 'arglist) | |
a8215aed LC |
512 | => (match-lambda |
513 | ((req opt keyword aok? rest) | |
fc835b1b AW |
514 | `((required . ,(if (number? req) |
515 | (make-list req '_) | |
516 | req)) | |
517 | (optional . ,(if (number? opt) | |
518 | (make-list opt '_) | |
519 | opt)) | |
a8215aed LC |
520 | (keyword . ,keyword) |
521 | (allow-other-keys? . ,aok?) | |
522 | (rest . ,rest))))) | |
0704c813 AW |
523 | ((procedure-source proc) |
524 | => cadr) | |
0bd1e9c6 | 525 | (((@ (system vm program) program?) proc) |
8470b3f4 | 526 | ((@ (system vm program) program-arguments-alist) proc)) |
0704c813 AW |
527 | (else #f))) |
528 | ||
529 | ||
de25f281 | 530 | ;;; session.scm ends here |