Commit | Line | Data |
---|---|---|
13ae9151 | 1 | ;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. |
0e81dabd MD |
2 | ;;;; |
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. | |
7 | ;;;; | |
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. | |
12 | ;;;; | |
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 | |
0e81dabd MD |
17 | ;;;; |
18 | \f | |
19 | ||
bbefd480 | 20 | (define-module (ice-9 session) |
3bdca000 | 21 | :use-module (ice-9 documentation) |
3510b484 | 22 | :use-module (ice-9 regex) |
3bdca000 | 23 | ) |
0e81dabd MD |
24 | |
25 | \f | |
26 | ||
13ae9151 MD |
27 | ;;; Documentation |
28 | ;;; | |
29 | (define-public help | |
30 | (procedure->syntax | |
31 | (lambda (exp env) | |
32 | "(help [NAME]) | |
33 | Prints useful information. Try `(help)'." | |
9f0eee46 MD |
34 | (cond ((not (= (length exp) 2)) |
35 | (help-usage)) | |
36 | ((not (feature? 'regex)) | |
37 | (display "`help' depends on the `regex' feature. | |
38 | You don't seem to have regular expressions installed.\n")) | |
39 | (else | |
40 | (let ((name (cadr exp))) | |
41 | (cond ((symbol? name) | |
42 | (help-doc name | |
43 | (string-append "^" | |
3510b484 MD |
44 | (regexp-quote |
45 | (symbol->string name)) | |
9f0eee46 MD |
46 | "$"))) |
47 | ((string? name) | |
48 | (help-doc name name)) | |
49 | ((and (list? name) | |
50 | (= (length name) 2) | |
51 | (eq? (car name) 'unquote)) | |
52 | (let ((doc (object-documentation (local-eval (cadr name) | |
53 | env)))) | |
54 | (if (not doc) | |
55 | (simple-format #t "No documentation found for ~S\n" | |
56 | (cadr name)) | |
57 | (write-line doc)))) | |
58 | (else | |
59 | (help-usage))) | |
60 | *unspecified*)))))) | |
13ae9151 | 61 | |
3bdca000 MD |
62 | (define (help-doc term regexp) |
63 | (let ((entries (apropos-fold (lambda (module name object data) | |
64 | (cons (list module | |
65 | name | |
66 | (object-documentation object)) | |
67 | data)) | |
68 | '() | |
69 | regexp | |
70 | apropos-fold-exported)) | |
71 | (module car) | |
72 | (name cadr) | |
73 | (doc caddr)) | |
74 | (if (null? entries) | |
75 | ;; no matches | |
76 | (begin | |
77 | (display "Did not find any object ") | |
78 | (simple-format #t | |
79 | (if (symbol? term) | |
80 | "named `~A'\n" | |
81 | "matching regexp \"~A\"\n") | |
82 | term)) | |
83 | (let ((first? #t)) | |
84 | (if (or-map doc entries) | |
85 | ;; entries with documentation | |
86 | (for-each (lambda (entry) | |
87 | ;; *fixme*: Use `describe' when we have GOOPS? | |
88 | (if (doc entry) | |
89 | (begin | |
90 | (if first? | |
91 | (set! first? #f) | |
92 | (newline)) | |
93 | (simple-format #t "~S: ~S\n~A\n" | |
94 | (module-name (module entry)) | |
95 | (name entry) | |
96 | (doc entry))))) | |
97 | entries)) | |
98 | (if (or-map (lambda (x) (not (doc x))) entries) | |
99 | ;; entries without documentation | |
100 | (begin | |
101 | (if (not first?) | |
102 | (display "\nNo documentation found for:\n")) | |
103 | (for-each (lambda (entry) | |
104 | (if (not (doc entry)) | |
105 | (simple-format #t "~S: ~S\n" | |
106 | (module-name (module entry)) | |
107 | (name entry)))) | |
108 | entries))))))) | |
109 | ||
13ae9151 | 110 | (define (help-usage) |
3bdca000 MD |
111 | (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) |
112 | (help REGEXP) ditto for objects with names matching REGEXP (a string) | |
d1c50f73 | 113 | (help ,EXPR) gives documentation for object returned by EXPR |
13ae9151 MD |
114 | (help) gives this text |
115 | ||
3bdca000 MD |
116 | `help' searches among bindings exported from loaded modules, while |
117 | `apropos' searches among bindings visible from the \"current\" module. | |
118 | ||
2f52380c MD |
119 | Examples: (help help) |
120 | (help cons) | |
3bdca000 | 121 | (help \"output-string\") |
13ae9151 MD |
122 | |
123 | Other useful sources of helpful information: | |
124 | ||
125 | (apropos STRING) | |
126 | (arity PROCEDURE) | |
127 | (name PROCEDURE-OR-MACRO) | |
128 | (source PROCEDURE-OR-MACRO) | |
129 | ||
130 | Tools: | |
131 | ||
2f52380c MD |
132 | (backtrace) ;show backtrace from last error |
133 | (debug) ;enter the debugger | |
134 | (trace [PROCEDURE]) ;trace procedure (no arg => show) | |
135 | (untrace [PROCEDURE]) ;untrace (no arg => untrace all) | |
13ae9151 MD |
136 | |
137 | (OPTIONSET-options 'full) ;display option information | |
138 | (OPTIONSET-enable 'OPTION) | |
139 | (OPTIONSET-disable 'OPTION) | |
140 | (OPTIONSET-set! OPTION VALUE) | |
141 | ||
142 | where OPTIONSET is one of debug, read, eval, print | |
143 | ||
144 | ")) | |
145 | ||
0e81dabd MD |
146 | ;;; {Apropos} |
147 | ;;; | |
148 | ;;; Author: Roland Orre <orre@nada.kth.se> | |
149 | ;;; | |
150 | ||
151 | (define (id x) x) | |
152 | ||
0e81dabd MD |
153 | (define-public (apropos rgx . options) |
154 | "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" | |
155 | (if (zero? (string-length rgx)) | |
156 | "Empty string not allowed" | |
4f161c5c | 157 | (let* ((match (make-regexp rgx)) |
0e81dabd MD |
158 | (modules (cons (current-module) |
159 | (module-uses (current-module)))) | |
160 | (separator #\tab) | |
161 | (shadow (member 'shadow options)) | |
162 | (value (member 'value options))) | |
163 | (cond ((member 'full options) | |
164 | (set! shadow #t) | |
165 | (set! value #t))) | |
166 | (for-each | |
167 | (lambda (module) | |
168 | (let* ((builtin (or (eq? module the-scm-module) | |
169 | (eq? module the-root-module))) | |
170 | (name (module-name module)) | |
171 | (obarrays (if builtin | |
172 | (list (builtin-weak-bindings) | |
173 | (builtin-bindings)) | |
174 | (list (module-obarray module)))) | |
175 | (get-refs (if builtin | |
176 | (list id id) | |
177 | (list variable-ref))) | |
178 | ) | |
179 | (for-each | |
180 | (lambda (obarray get-ref) | |
68aed3ea | 181 | (array-for-each |
0e81dabd MD |
182 | (lambda (oblist) |
183 | (for-each | |
184 | (lambda (x) | |
4f161c5c | 185 | (cond ((regexp-exec match (car x)) |
0e81dabd MD |
186 | (display name) |
187 | (display ": ") | |
188 | (display (car x)) | |
189 | (cond ((procedure? (get-ref (cdr x))) | |
190 | (display separator) | |
191 | (display (get-ref (cdr x)))) | |
192 | (value | |
193 | (display separator) | |
194 | (display (get-ref (cdr x))))) | |
195 | (if (and shadow | |
196 | (not (eq? (module-ref module | |
197 | (car x)) | |
198 | (module-ref (current-module) | |
199 | (car x))))) | |
200 | (display " shadowed")) | |
201 | (newline) | |
202 | ))) | |
203 | oblist)) | |
204 | obarray)) | |
205 | obarrays get-refs))) | |
206 | modules)))) | |
68aed3ea MD |
207 | |
208 | (define-public (apropos-internal rgx) | |
209 | "Return a list of accessible variable names." | |
3bdca000 MD |
210 | (apropos-fold (lambda (module name var data) |
211 | (cons name data)) | |
212 | '() | |
213 | rgx | |
214 | (apropos-fold-accessible (current-module)))) | |
215 | ||
216 | (define-public (apropos-fold proc init rgx folder) | |
217 | "Folds PROCEDURE over bindings matching third arg REGEXP. | |
218 | ||
219 | Result is | |
220 | ||
221 | (PROCEDURE MODULE1 NAME1 VALUE1 | |
222 | (PROCEDURE MODULE2 NAME2 VALUE2 | |
223 | ... | |
224 | (PROCEDURE MODULEn NAMEn VALUEn INIT))) | |
225 | ||
226 | where INIT is the second arg to `apropos-fold'. | |
227 | ||
228 | Fourth arg FOLDER is one of | |
229 | ||
230 | (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE | |
231 | apropos-fold-exported ;fold over all exported bindings | |
232 | apropos-fold-all ;fold over all bindings" | |
233 | (let ((match (make-regexp rgx)) | |
234 | (recorded (make-vector 61 '()))) | |
235 | (let ((fold-module | |
236 | (lambda (module data) | |
237 | (let* ((obarray-filter | |
238 | (lambda (name val data) | |
239 | (if (and (regexp-exec match name) | |
240 | (not (hashq-get-handle recorded name))) | |
241 | (begin | |
242 | (hashq-set! recorded name #t) | |
243 | (proc module name val data)) | |
244 | data))) | |
245 | (module-filter | |
246 | (lambda (name var data) | |
247 | (obarray-filter name (variable-ref var) data)))) | |
248 | (cond ((or (eq? module the-scm-module) | |
249 | (eq? module the-root-module)) | |
250 | (hash-fold obarray-filter | |
251 | (hash-fold obarray-filter | |
252 | data | |
253 | (builtin-bindings)) | |
254 | (builtin-weak-bindings))) | |
255 | (module (hash-fold module-filter | |
256 | data | |
257 | (module-obarray module))) | |
258 | (else data)))))) | |
259 | (folder fold-module init)))) | |
260 | ||
261 | (define (make-fold-modules init-thunk traverse extract) | |
262 | "Return procedure capable of traversing a forest of modules. | |
263 | The forest traversed is the image of the forest generated by root | |
264 | modules returned by INIT-THUNK and the generator TRAVERSE. | |
265 | It is an image under the mapping EXTRACT." | |
266 | (lambda (fold-module init) | |
9aec4751 MD |
267 | (let* ((table (make-hash-table 31)) |
268 | (first? (lambda (obj) | |
8d627248 MD |
269 | (let* ((handle (hash-create-handle! table obj #t)) |
270 | (first? (cdr handle))) | |
271 | (set-cdr! handle #f) | |
272 | first?)))) | |
9aec4751 MD |
273 | (let rec ((data init) |
274 | (modules (init-thunk))) | |
275 | (do ((modules modules (cdr modules)) | |
276 | (data data (if (first? (car modules)) | |
277 | (rec (fold-module (extract (car modules)) data) | |
278 | (traverse (car modules))) | |
279 | data))) | |
280 | ((null? modules) data)))))) | |
3bdca000 MD |
281 | |
282 | (define-public (apropos-fold-accessible module) | |
283 | (make-fold-modules (lambda () (list module)) | |
284 | module-uses | |
285 | (lambda (x) x))) | |
286 | ||
287 | (define (root-modules) | |
288 | (cons the-root-module | |
289 | (submodules (nested-ref the-root-module '(app modules))))) | |
290 | ||
291 | (define (submodules m) | |
292 | (hash-fold (lambda (name var data) | |
293 | (let ((obj (variable-ref var))) | |
294 | (if (and (module? obj) | |
295 | (eq? (module-kind obj) 'directory)) | |
296 | (cons obj data) | |
297 | data))) | |
298 | '() | |
299 | (module-obarray m))) | |
300 | ||
301 | (define-public apropos-fold-exported | |
302 | (make-fold-modules root-modules submodules module-public-interface)) | |
303 | ||
304 | (define-public apropos-fold-all | |
305 | (make-fold-modules root-modules submodules (lambda (x) x))) | |
7cfae7e6 MD |
306 | |
307 | (define-public (source obj) | |
308 | (cond ((procedure? obj) (procedure-source obj)) | |
309 | ((macro? obj) (procedure-source (macro-transformer obj))) | |
310 | (else #f))) | |
4a9f464e MD |
311 | |
312 | (define-public (arity obj) | |
313 | (let ((arity (procedure-property obj 'arity))) | |
314 | (display (car arity)) | |
315 | (cond ((caddr arity) | |
316 | (display " or more")) | |
317 | ((not (zero? (cadr arity))) | |
318 | (display " required and ") | |
319 | (display (cadr arity)) | |
320 | (display " optional"))) | |
321 | (if (and (not (caddr arity)) | |
322 | (= (car arity) 1) | |
323 | (<= (cadr arity) 1)) | |
324 | (display " argument") | |
325 | (display " arguments")) | |
326 | (if (closure? obj) | |
327 | (let ((formals (cadr (procedure-source obj)))) | |
328 | (if (pair? formals) | |
329 | (begin | |
330 | (display ": `") | |
331 | (display (car formals)) | |
332 | (let loop ((ls (cdr formals))) | |
333 | (cond ((null? ls) | |
334 | (display #\')) | |
335 | ((not (pair? ls)) | |
336 | (display "', the rest in `") | |
337 | (display ls) | |
338 | (display #\')) | |
339 | (else | |
340 | (if (pair? (cdr ls)) | |
341 | (display "', `") | |
342 | (display "' and `")) | |
343 | (display (car ls)) | |
344 | (loop (cdr ls)))))) | |
345 | (begin | |
346 | (display " in `") | |
347 | (display formals) | |
348 | (display #\'))))) | |
349 | (display ".\n"))) | |
6ae34994 MD |
350 | |
351 | (define-public system-module | |
352 | (procedure->syntax | |
353 | (lambda (exp env) | |
354 | (let* ((m (nested-ref the-root-module | |
355 | (append '(app modules) (cadr exp))))) | |
356 | (if (not m) | |
357 | (error "Couldn't find any module named" (cadr exp))) | |
358 | (let ((s (not (procedure-property (module-eval-closure m) | |
359 | 'system-module)))) | |
360 | (set-system-module! m s) | |
361 | (string-append "Module " (symbol->string (module-name m)) | |
362 | " is now a " (if s "system" "user") " module.")))))) |