Commit | Line | Data |
---|---|---|
7bb1bfc2 TTN |
1 | ;;;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc. |
2 | ;;;; | |
0e81dabd MD |
3 | ;;;; This program is free software; you can redistribute it and/or modify |
4 | ;;;; it under the terms of the GNU General Public License as published by | |
5 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
6 | ;;;; any later version. | |
7bb1bfc2 | 7 | ;;;; |
0e81dabd MD |
8 | ;;;; This program is distributed in the hope that it will be useful, |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ;;;; GNU General Public License for more details. | |
7bb1bfc2 | 12 | ;;;; |
0e81dabd MD |
13 | ;;;; You should have received a copy of the GNU General Public License |
14 | ;;;; along with this software; see the file COPYING. If not, write to | |
c6e23ea2 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
7bb1bfc2 | 17 | ;;;; |
a482f2cc MV |
18 | ;;;; As a special exception, the Free Software Foundation gives permission |
19 | ;;;; for additional uses of the text contained in its release of GUILE. | |
20 | ;;;; | |
21 | ;;;; The exception is that, if you link the GUILE library with other files | |
22 | ;;;; to produce an executable, this does not by itself cause the | |
23 | ;;;; resulting executable to be covered by the GNU General Public License. | |
24 | ;;;; Your use of that executable is in no way restricted on account of | |
25 | ;;;; linking the GUILE library code into it. | |
26 | ;;;; | |
27 | ;;;; This exception does not however invalidate any other reasons why | |
28 | ;;;; the executable file might be covered by the GNU General Public License. | |
29 | ;;;; | |
30 | ;;;; This exception applies only to the code released by the | |
31 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
32 | ;;;; code from other Free Software Foundation releases into a copy of | |
33 | ;;;; GUILE, as the General Public License permits, the exception does | |
34 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
35 | ;;;; anyone as to the status of such modified files, you must delete | |
36 | ;;;; this exception notice from them. | |
37 | ;;;; | |
38 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
39 | ;;;; whether to permit this exception to apply to your modifications. | |
40 | ;;;; If you do not wish that, delete this exception notice. | |
41 | ;;;; | |
0e81dabd MD |
42 | \f |
43 | ||
bbefd480 | 44 | (define-module (ice-9 session) |
3bdca000 | 45 | :use-module (ice-9 documentation) |
3510b484 | 46 | :use-module (ice-9 regex) |
7bb1bfc2 | 47 | :use-module (ice-9 rdelim)) |
0e81dabd MD |
48 | |
49 | \f | |
50 | ||
13ae9151 MD |
51 | ;;; Documentation |
52 | ;;; | |
53 | (define-public help | |
54 | (procedure->syntax | |
55 | (lambda (exp env) | |
56 | "(help [NAME]) | |
57 | Prints useful information. Try `(help)'." | |
9f0eee46 | 58 | (cond ((not (= (length exp) 2)) |
de25f281 TTN |
59 | (help-usage)) |
60 | ((not (provided? 'regex)) | |
61 | (display "`help' depends on the `regex' feature. | |
9f0eee46 | 62 | You don't seem to have regular expressions installed.\n")) |
de25f281 TTN |
63 | (else |
64 | (let ((name (cadr exp)) | |
65 | (not-found (lambda (type x) | |
66 | (simple-format #t "No ~A found for ~A\n" | |
67 | type x)))) | |
68 | (cond | |
69 | ||
70 | ;; SYMBOL | |
71 | ((symbol? name) | |
72 | (help-doc name | |
73 | (simple-format | |
74 | #f "^~A$" | |
75 | (regexp-quote (symbol->string name))))) | |
76 | ||
77 | ;; "STRING" | |
78 | ((string? name) | |
79 | (help-doc name name)) | |
80 | ||
81 | ;; (unquote SYMBOL) | |
82 | ((and (list? name) | |
83 | (= (length name) 2) | |
84 | (eq? (car name) 'unquote)) | |
85 | (cond ((object-documentation | |
86 | (local-eval (cadr name) env)) | |
87 | => write-line) | |
88 | (else (not-found 'documentation (cadr name))))) | |
89 | ||
90 | ;; (quote SYMBOL) | |
91 | ((and (list? name) | |
92 | (= (length name) 2) | |
93 | (eq? (car name) 'quote) | |
94 | (symbol? (cadr name))) | |
95 | (cond ((search-documentation-files (cadr name)) | |
96 | => write-line) | |
97 | (else (not-found 'documentation (cadr name))))) | |
98 | ||
99 | ;; (SYM1 SYM2 ...) | |
100 | ((and (list? name) | |
101 | (and-map symbol? name) | |
102 | (not (null? name)) | |
103 | (not (eq? (car name) 'quote))) | |
104 | (cond ((module-commentary name) | |
105 | => (lambda (doc) | |
106 | (display name) (write-line " commentary:") | |
107 | (write-line doc))) | |
108 | (else (not-found 'commentary name)))) | |
109 | ||
110 | ;; unrecognized | |
111 | (else | |
112 | (help-usage))) | |
113 | *unspecified*)))))) | |
13ae9151 | 114 | |
7bb1bfc2 TTN |
115 | (define (module-filename name) ; fixme: better way? / done elsewhere? |
116 | (let* ((name (map symbol->string name)) | |
117 | (reverse-name (reverse name)) | |
118 | (leaf (car reverse-name)) | |
119 | (dir-hint-module-name (reverse (cdr reverse-name))) | |
120 | (dir-hint (apply string-append | |
121 | (map (lambda (elt) | |
122 | (string-append elt "/")) | |
123 | dir-hint-module-name)))) | |
124 | (%search-load-path (in-vicinity dir-hint leaf)))) | |
125 | ||
126 | (define (module-commentary name) | |
127 | (cond ((module-filename name) => file-commentary) | |
128 | (else #f))) | |
129 | ||
3bdca000 MD |
130 | (define (help-doc term regexp) |
131 | (let ((entries (apropos-fold (lambda (module name object data) | |
132 | (cons (list module | |
133 | name | |
db611983 NJ |
134 | (object-documentation object) |
135 | (cond ((closure? object) | |
136 | "a procedure") | |
137 | ((procedure? object) | |
138 | "a primitive procedure") | |
139 | (else | |
140 | "an object"))) | |
3bdca000 MD |
141 | data)) |
142 | '() | |
143 | regexp | |
144 | apropos-fold-exported)) | |
145 | (module car) | |
146 | (name cadr) | |
db611983 NJ |
147 | (doc caddr) |
148 | (type cadddr)) | |
de25f281 TTN |
149 | (cond ((not (null? entries)) |
150 | (let ((first? #t) | |
151 | (undocumented-entries '()) | |
152 | (documented-entries '()) | |
153 | (documentations '())) | |
154 | ||
155 | (for-each (lambda (entry) | |
156 | (let ((entry-summary (simple-format | |
157 | #f "~S: ~S\n" | |
158 | (module-name (module entry)) | |
159 | (name entry)))) | |
160 | (if (doc entry) | |
161 | (begin | |
162 | (set! documented-entries | |
163 | (cons entry-summary documented-entries)) | |
164 | ;; *fixme*: Use `describe' when we have GOOPS? | |
165 | (set! documentations | |
166 | (cons (simple-format | |
167 | #f "`~S' is ~A in the ~S module.\n\n~A\n" | |
168 | (name entry) | |
169 | (type entry) | |
170 | (module-name (module entry)) | |
171 | (doc entry)) | |
172 | documentations))) | |
173 | (set! undocumented-entries | |
174 | (cons entry-summary | |
175 | undocumented-entries))))) | |
176 | entries) | |
177 | ||
178 | (if (and (not (null? documented-entries)) | |
179 | (or (> (length documented-entries) 1) | |
180 | (not (null? undocumented-entries)))) | |
181 | (begin | |
182 | (display "Documentation found for:\n") | |
183 | (for-each (lambda (entry) (display entry)) | |
184 | documented-entries) | |
185 | (set! first? #f))) | |
186 | ||
187 | (for-each (lambda (entry) | |
188 | (if first? | |
189 | (set! first? #f) | |
190 | (newline)) | |
191 | (display entry)) | |
192 | documentations) | |
193 | ||
194 | (if (not (null? undocumented-entries)) | |
195 | (begin | |
196 | (if first? | |
197 | (set! first? #f) | |
198 | (newline)) | |
199 | (display "No documentation found for:\n") | |
200 | (for-each (lambda (entry) (display entry)) | |
201 | undocumented-entries))))) | |
202 | ((search-documentation-files term) | |
203 | => (lambda (doc) | |
204 | (write-line "Documentation from file:") | |
205 | (write-line doc))) | |
206 | (else | |
207 | ;; no matches | |
208 | (display "Did not find any object ") | |
209 | (simple-format #t | |
210 | (if (symbol? term) | |
211 | "named `~A'\n" | |
212 | "matching regexp \"~A\"\n") | |
213 | term))))) | |
3bdca000 | 214 | |
13ae9151 | 215 | (define (help-usage) |
3bdca000 MD |
216 | (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) |
217 | (help REGEXP) ditto for objects with names matching REGEXP (a string) | |
1de3b33b | 218 | (help 'NAME) gives documentation for NAME, even if it is not an object |
d1c50f73 | 219 | (help ,EXPR) gives documentation for object returned by EXPR |
8bbe4c82 | 220 | (help (my module)) gives module commentary for `(my module)' |
13ae9151 MD |
221 | (help) gives this text |
222 | ||
3bdca000 MD |
223 | `help' searches among bindings exported from loaded modules, while |
224 | `apropos' searches among bindings visible from the \"current\" module. | |
225 | ||
2f52380c MD |
226 | Examples: (help help) |
227 | (help cons) | |
3bdca000 | 228 | (help \"output-string\") |
13ae9151 MD |
229 | |
230 | Other useful sources of helpful information: | |
231 | ||
232 | (apropos STRING) | |
233 | (arity PROCEDURE) | |
234 | (name PROCEDURE-OR-MACRO) | |
235 | (source PROCEDURE-OR-MACRO) | |
236 | ||
237 | Tools: | |
238 | ||
2f52380c MD |
239 | (backtrace) ;show backtrace from last error |
240 | (debug) ;enter the debugger | |
241 | (trace [PROCEDURE]) ;trace procedure (no arg => show) | |
242 | (untrace [PROCEDURE]) ;untrace (no arg => untrace all) | |
13ae9151 MD |
243 | |
244 | (OPTIONSET-options 'full) ;display option information | |
245 | (OPTIONSET-enable 'OPTION) | |
246 | (OPTIONSET-disable 'OPTION) | |
247 | (OPTIONSET-set! OPTION VALUE) | |
248 | ||
249 | where OPTIONSET is one of debug, read, eval, print | |
250 | ||
251 | ")) | |
252 | ||
0e81dabd MD |
253 | ;;; {Apropos} |
254 | ;;; | |
255 | ;;; Author: Roland Orre <orre@nada.kth.se> | |
256 | ;;; | |
257 | ||
0e81dabd MD |
258 | (define-public (apropos rgx . options) |
259 | "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" | |
260 | (if (zero? (string-length rgx)) | |
261 | "Empty string not allowed" | |
4f161c5c | 262 | (let* ((match (make-regexp rgx)) |
0e81dabd MD |
263 | (modules (cons (current-module) |
264 | (module-uses (current-module)))) | |
265 | (separator #\tab) | |
266 | (shadow (member 'shadow options)) | |
267 | (value (member 'value options))) | |
268 | (cond ((member 'full options) | |
269 | (set! shadow #t) | |
270 | (set! value #t))) | |
271 | (for-each | |
272 | (lambda (module) | |
296ff5e7 MV |
273 | (let* ((name (module-name module)) |
274 | (obarray (module-obarray module))) | |
275 | ;; XXX - should use hash-fold here | |
10764e3c DH |
276 | (array-for-each |
277 | (lambda (oblist) | |
278 | (for-each | |
279 | (lambda (x) | |
280 | (cond ((regexp-exec match (symbol->string (car x))) | |
281 | (display name) | |
282 | (display ": ") | |
283 | (display (car x)) | |
aef9dd65 MV |
284 | (cond ((variable-bound? (cdr x)) |
285 | (let ((val (variable-ref (cdr x)))) | |
286 | (cond ((or (procedure? val) value) | |
287 | (display separator) | |
288 | (display val))))) | |
289 | (else | |
10764e3c | 290 | (display separator) |
aef9dd65 | 291 | (display "(unbound)"))) |
10764e3c DH |
292 | (if (and shadow |
293 | (not (eq? (module-ref module | |
294 | (car x)) | |
295 | (module-ref (current-module) | |
296 | (car x))))) | |
297 | (display " shadowed")) | |
296ff5e7 | 298 | (newline)))) |
10764e3c DH |
299 | oblist)) |
300 | obarray))) | |
0e81dabd | 301 | modules)))) |
68aed3ea MD |
302 | |
303 | (define-public (apropos-internal rgx) | |
304 | "Return a list of accessible variable names." | |
3bdca000 MD |
305 | (apropos-fold (lambda (module name var data) |
306 | (cons name data)) | |
307 | '() | |
308 | rgx | |
309 | (apropos-fold-accessible (current-module)))) | |
310 | ||
311 | (define-public (apropos-fold proc init rgx folder) | |
312 | "Folds PROCEDURE over bindings matching third arg REGEXP. | |
313 | ||
314 | Result is | |
315 | ||
316 | (PROCEDURE MODULE1 NAME1 VALUE1 | |
317 | (PROCEDURE MODULE2 NAME2 VALUE2 | |
318 | ... | |
319 | (PROCEDURE MODULEn NAMEn VALUEn INIT))) | |
320 | ||
321 | where INIT is the second arg to `apropos-fold'. | |
322 | ||
323 | Fourth arg FOLDER is one of | |
324 | ||
325 | (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE | |
326 | apropos-fold-exported ;fold over all exported bindings | |
327 | apropos-fold-all ;fold over all bindings" | |
328 | (let ((match (make-regexp rgx)) | |
329 | (recorded (make-vector 61 '()))) | |
330 | (let ((fold-module | |
331 | (lambda (module data) | |
332 | (let* ((obarray-filter | |
333 | (lambda (name val data) | |
4adc3028 | 334 | (if (and (regexp-exec match (symbol->string name)) |
3bdca000 MD |
335 | (not (hashq-get-handle recorded name))) |
336 | (begin | |
337 | (hashq-set! recorded name #t) | |
338 | (proc module name val data)) | |
339 | data))) | |
340 | (module-filter | |
341 | (lambda (name var data) | |
aef9dd65 MV |
342 | (if (variable-bound? var) |
343 | (obarray-filter name (variable-ref var) data) | |
344 | data)))) | |
296ff5e7 | 345 | (cond (module (hash-fold module-filter |
3bdca000 MD |
346 | data |
347 | (module-obarray module))) | |
348 | (else data)))))) | |
349 | (folder fold-module init)))) | |
350 | ||
351 | (define (make-fold-modules init-thunk traverse extract) | |
352 | "Return procedure capable of traversing a forest of modules. | |
353 | The forest traversed is the image of the forest generated by root | |
354 | modules returned by INIT-THUNK and the generator TRAVERSE. | |
355 | It is an image under the mapping EXTRACT." | |
356 | (lambda (fold-module init) | |
9aec4751 MD |
357 | (let* ((table (make-hash-table 31)) |
358 | (first? (lambda (obj) | |
8d627248 MD |
359 | (let* ((handle (hash-create-handle! table obj #t)) |
360 | (first? (cdr handle))) | |
361 | (set-cdr! handle #f) | |
362 | first?)))) | |
9aec4751 MD |
363 | (let rec ((data init) |
364 | (modules (init-thunk))) | |
365 | (do ((modules modules (cdr modules)) | |
366 | (data data (if (first? (car modules)) | |
367 | (rec (fold-module (extract (car modules)) data) | |
368 | (traverse (car modules))) | |
369 | data))) | |
370 | ((null? modules) data)))))) | |
3bdca000 MD |
371 | |
372 | (define-public (apropos-fold-accessible module) | |
373 | (make-fold-modules (lambda () (list module)) | |
374 | module-uses | |
de25f281 | 375 | identity)) |
3bdca000 MD |
376 | |
377 | (define (root-modules) | |
378 | (cons the-root-module | |
379 | (submodules (nested-ref the-root-module '(app modules))))) | |
380 | ||
381 | (define (submodules m) | |
382 | (hash-fold (lambda (name var data) | |
aef9dd65 | 383 | (let ((obj (and (variable-bound? var) (variable-ref var)))) |
3bdca000 MD |
384 | (if (and (module? obj) |
385 | (eq? (module-kind obj) 'directory)) | |
386 | (cons obj data) | |
387 | data))) | |
388 | '() | |
389 | (module-obarray m))) | |
390 | ||
391 | (define-public apropos-fold-exported | |
392 | (make-fold-modules root-modules submodules module-public-interface)) | |
393 | ||
394 | (define-public apropos-fold-all | |
de25f281 | 395 | (make-fold-modules root-modules submodules identity)) |
7cfae7e6 MD |
396 | |
397 | (define-public (source obj) | |
398 | (cond ((procedure? obj) (procedure-source obj)) | |
399 | ((macro? obj) (procedure-source (macro-transformer obj))) | |
400 | (else #f))) | |
4a9f464e MD |
401 | |
402 | (define-public (arity obj) | |
403 | (let ((arity (procedure-property obj 'arity))) | |
404 | (display (car arity)) | |
405 | (cond ((caddr arity) | |
406 | (display " or more")) | |
407 | ((not (zero? (cadr arity))) | |
408 | (display " required and ") | |
409 | (display (cadr arity)) | |
410 | (display " optional"))) | |
411 | (if (and (not (caddr arity)) | |
412 | (= (car arity) 1) | |
413 | (<= (cadr arity) 1)) | |
414 | (display " argument") | |
415 | (display " arguments")) | |
416 | (if (closure? obj) | |
417 | (let ((formals (cadr (procedure-source obj)))) | |
418 | (if (pair? formals) | |
419 | (begin | |
420 | (display ": `") | |
421 | (display (car formals)) | |
422 | (let loop ((ls (cdr formals))) | |
423 | (cond ((null? ls) | |
424 | (display #\')) | |
425 | ((not (pair? ls)) | |
426 | (display "', the rest in `") | |
427 | (display ls) | |
428 | (display #\')) | |
429 | (else | |
430 | (if (pair? (cdr ls)) | |
431 | (display "', `") | |
432 | (display "' and `")) | |
433 | (display (car ls)) | |
434 | (loop (cdr ls)))))) | |
435 | (begin | |
436 | (display " in `") | |
437 | (display formals) | |
438 | (display #\'))))) | |
439 | (display ".\n"))) | |
6ae34994 MD |
440 | |
441 | (define-public system-module | |
442 | (procedure->syntax | |
443 | (lambda (exp env) | |
444 | (let* ((m (nested-ref the-root-module | |
445 | (append '(app modules) (cadr exp))))) | |
446 | (if (not m) | |
447 | (error "Couldn't find any module named" (cadr exp))) | |
448 | (let ((s (not (procedure-property (module-eval-closure m) | |
449 | 'system-module)))) | |
450 | (set-system-module! m s) | |
451 | (string-append "Module " (symbol->string (module-name m)) | |
452 | " is now a " (if s "system" "user") " module.")))))) | |
de25f281 TTN |
453 | |
454 | ;;; session.scm ends here |