| 1 | ;;;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc. |
| 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 |
| 15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
| 16 | ;;;; Boston, MA 02111-1307 USA |
| 17 | ;;;; |
| 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 | ;;;; |
| 42 | \f |
| 43 | |
| 44 | (define-module (ice-9 session) |
| 45 | :use-module (ice-9 documentation) |
| 46 | :use-module (ice-9 regex) |
| 47 | :use-module (ice-9 rdelim) |
| 48 | :export (help apropos apropos-internal apropos-fold |
| 49 | apropos-fold-accessible apropos-fold-exported apropos-fold-all |
| 50 | source arity system-module)) |
| 51 | |
| 52 | \f |
| 53 | |
| 54 | ;;; Documentation |
| 55 | ;;; |
| 56 | (define help |
| 57 | (procedure->syntax |
| 58 | (lambda (exp env) |
| 59 | "(help [NAME]) |
| 60 | Prints useful information. Try `(help)'." |
| 61 | (cond ((not (= (length exp) 2)) |
| 62 | (help-usage)) |
| 63 | ((not (provided? 'regex)) |
| 64 | (display "`help' depends on the `regex' feature. |
| 65 | You don't seem to have regular expressions installed.\n")) |
| 66 | (else |
| 67 | (let ((name (cadr exp)) |
| 68 | (not-found (lambda (type x) |
| 69 | (simple-format #t "No ~A found for ~A\n" |
| 70 | type x)))) |
| 71 | (cond |
| 72 | |
| 73 | ;; SYMBOL |
| 74 | ((symbol? name) |
| 75 | (help-doc name |
| 76 | (simple-format |
| 77 | #f "^~A$" |
| 78 | (regexp-quote (symbol->string name))))) |
| 79 | |
| 80 | ;; "STRING" |
| 81 | ((string? name) |
| 82 | (help-doc name name)) |
| 83 | |
| 84 | ;; (unquote SYMBOL) |
| 85 | ((and (list? name) |
| 86 | (= (length name) 2) |
| 87 | (eq? (car name) 'unquote)) |
| 88 | (cond ((object-documentation |
| 89 | (local-eval (cadr name) env)) |
| 90 | => write-line) |
| 91 | (else (not-found 'documentation (cadr name))))) |
| 92 | |
| 93 | ;; (quote SYMBOL) |
| 94 | ((and (list? name) |
| 95 | (= (length name) 2) |
| 96 | (eq? (car name) 'quote) |
| 97 | (symbol? (cadr name))) |
| 98 | (cond ((search-documentation-files (cadr name)) |
| 99 | => write-line) |
| 100 | (else (not-found 'documentation (cadr name))))) |
| 101 | |
| 102 | ;; (SYM1 SYM2 ...) |
| 103 | ((and (list? name) |
| 104 | (and-map symbol? name) |
| 105 | (not (null? name)) |
| 106 | (not (eq? (car name) 'quote))) |
| 107 | (cond ((module-commentary name) |
| 108 | => (lambda (doc) |
| 109 | (display name) (write-line " commentary:") |
| 110 | (write-line doc))) |
| 111 | (else (not-found 'commentary name)))) |
| 112 | |
| 113 | ;; unrecognized |
| 114 | (else |
| 115 | (help-usage))) |
| 116 | *unspecified*)))))) |
| 117 | |
| 118 | (define (module-filename name) ; fixme: better way? / done elsewhere? |
| 119 | (let* ((name (map symbol->string name)) |
| 120 | (reverse-name (reverse name)) |
| 121 | (leaf (car reverse-name)) |
| 122 | (dir-hint-module-name (reverse (cdr reverse-name))) |
| 123 | (dir-hint (apply string-append |
| 124 | (map (lambda (elt) |
| 125 | (string-append elt "/")) |
| 126 | dir-hint-module-name)))) |
| 127 | (%search-load-path (in-vicinity dir-hint leaf)))) |
| 128 | |
| 129 | (define (module-commentary name) |
| 130 | (cond ((module-filename name) => file-commentary) |
| 131 | (else #f))) |
| 132 | |
| 133 | (define (help-doc term regexp) |
| 134 | (let ((entries (apropos-fold (lambda (module name object data) |
| 135 | (cons (list module |
| 136 | name |
| 137 | (object-documentation object) |
| 138 | (cond ((closure? object) |
| 139 | "a procedure") |
| 140 | ((procedure? object) |
| 141 | "a primitive procedure") |
| 142 | (else |
| 143 | "an object"))) |
| 144 | data)) |
| 145 | '() |
| 146 | regexp |
| 147 | apropos-fold-exported)) |
| 148 | (module car) |
| 149 | (name cadr) |
| 150 | (doc caddr) |
| 151 | (type cadddr)) |
| 152 | (cond ((not (null? entries)) |
| 153 | (let ((first? #t) |
| 154 | (undocumented-entries '()) |
| 155 | (documented-entries '()) |
| 156 | (documentations '())) |
| 157 | |
| 158 | (for-each (lambda (entry) |
| 159 | (let ((entry-summary (simple-format |
| 160 | #f "~S: ~S\n" |
| 161 | (module-name (module entry)) |
| 162 | (name entry)))) |
| 163 | (if (doc entry) |
| 164 | (begin |
| 165 | (set! documented-entries |
| 166 | (cons entry-summary documented-entries)) |
| 167 | ;; *fixme*: Use `describe' when we have GOOPS? |
| 168 | (set! documentations |
| 169 | (cons (simple-format |
| 170 | #f "`~S' is ~A in the ~S module.\n\n~A\n" |
| 171 | (name entry) |
| 172 | (type entry) |
| 173 | (module-name (module entry)) |
| 174 | (doc entry)) |
| 175 | documentations))) |
| 176 | (set! undocumented-entries |
| 177 | (cons entry-summary |
| 178 | undocumented-entries))))) |
| 179 | entries) |
| 180 | |
| 181 | (if (and (not (null? documented-entries)) |
| 182 | (or (> (length documented-entries) 1) |
| 183 | (not (null? undocumented-entries)))) |
| 184 | (begin |
| 185 | (display "Documentation found for:\n") |
| 186 | (for-each (lambda (entry) (display entry)) |
| 187 | documented-entries) |
| 188 | (set! first? #f))) |
| 189 | |
| 190 | (for-each (lambda (entry) |
| 191 | (if first? |
| 192 | (set! first? #f) |
| 193 | (newline)) |
| 194 | (display entry)) |
| 195 | documentations) |
| 196 | |
| 197 | (if (not (null? undocumented-entries)) |
| 198 | (begin |
| 199 | (if first? |
| 200 | (set! first? #f) |
| 201 | (newline)) |
| 202 | (display "No documentation found for:\n") |
| 203 | (for-each (lambda (entry) (display entry)) |
| 204 | undocumented-entries))))) |
| 205 | ((search-documentation-files term) |
| 206 | => (lambda (doc) |
| 207 | (write-line "Documentation from file:") |
| 208 | (write-line doc))) |
| 209 | (else |
| 210 | ;; no matches |
| 211 | (display "Did not find any object ") |
| 212 | (simple-format #t |
| 213 | (if (symbol? term) |
| 214 | "named `~A'\n" |
| 215 | "matching regexp \"~A\"\n") |
| 216 | term))))) |
| 217 | |
| 218 | (define (help-usage) |
| 219 | (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol) |
| 220 | (help REGEXP) ditto for objects with names matching REGEXP (a string) |
| 221 | (help 'NAME) gives documentation for NAME, even if it is not an object |
| 222 | (help ,EXPR) gives documentation for object returned by EXPR |
| 223 | (help (my module)) gives module commentary for `(my module)' |
| 224 | (help) gives this text |
| 225 | |
| 226 | `help' searches among bindings exported from loaded modules, while |
| 227 | `apropos' searches among bindings visible from the \"current\" module. |
| 228 | |
| 229 | Examples: (help help) |
| 230 | (help cons) |
| 231 | (help \"output-string\") |
| 232 | |
| 233 | Other useful sources of helpful information: |
| 234 | |
| 235 | (apropos STRING) |
| 236 | (arity PROCEDURE) |
| 237 | (name PROCEDURE-OR-MACRO) |
| 238 | (source PROCEDURE-OR-MACRO) |
| 239 | |
| 240 | Tools: |
| 241 | |
| 242 | (backtrace) ;show backtrace from last error |
| 243 | (debug) ;enter the debugger |
| 244 | (trace [PROCEDURE]) ;trace procedure (no arg => show) |
| 245 | (untrace [PROCEDURE]) ;untrace (no arg => untrace all) |
| 246 | |
| 247 | (OPTIONSET-options 'full) ;display option information |
| 248 | (OPTIONSET-enable 'OPTION) |
| 249 | (OPTIONSET-disable 'OPTION) |
| 250 | (OPTIONSET-set! OPTION VALUE) |
| 251 | |
| 252 | where OPTIONSET is one of debug, read, eval, print |
| 253 | |
| 254 | ")) |
| 255 | |
| 256 | ;;; {Apropos} |
| 257 | ;;; |
| 258 | ;;; Author: Roland Orre <orre@nada.kth.se> |
| 259 | ;;; |
| 260 | |
| 261 | (define (apropos rgx . options) |
| 262 | "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" |
| 263 | (if (zero? (string-length rgx)) |
| 264 | "Empty string not allowed" |
| 265 | (let* ((match (make-regexp rgx)) |
| 266 | (modules (cons (current-module) |
| 267 | (module-uses (current-module)))) |
| 268 | (separator #\tab) |
| 269 | (shadow (member 'shadow options)) |
| 270 | (value (member 'value options))) |
| 271 | (cond ((member 'full options) |
| 272 | (set! shadow #t) |
| 273 | (set! value #t))) |
| 274 | (for-each |
| 275 | (lambda (module) |
| 276 | (let* ((name (module-name module)) |
| 277 | (obarray (module-obarray module))) |
| 278 | ;; XXX - should use hash-fold here |
| 279 | (array-for-each |
| 280 | (lambda (oblist) |
| 281 | (for-each |
| 282 | (lambda (x) |
| 283 | (cond ((regexp-exec match (symbol->string (car x))) |
| 284 | (display name) |
| 285 | (display ": ") |
| 286 | (display (car x)) |
| 287 | (cond ((variable-bound? (cdr x)) |
| 288 | (let ((val (variable-ref (cdr x)))) |
| 289 | (cond ((or (procedure? val) value) |
| 290 | (display separator) |
| 291 | (display val))))) |
| 292 | (else |
| 293 | (display separator) |
| 294 | (display "(unbound)"))) |
| 295 | (if (and shadow |
| 296 | (not (eq? (module-ref module |
| 297 | (car x)) |
| 298 | (module-ref (current-module) |
| 299 | (car x))))) |
| 300 | (display " shadowed")) |
| 301 | (newline)))) |
| 302 | oblist)) |
| 303 | obarray))) |
| 304 | modules)))) |
| 305 | |
| 306 | (define (apropos-internal rgx) |
| 307 | "Return a list of accessible variable names." |
| 308 | (apropos-fold (lambda (module name var data) |
| 309 | (cons name data)) |
| 310 | '() |
| 311 | rgx |
| 312 | (apropos-fold-accessible (current-module)))) |
| 313 | |
| 314 | (define (apropos-fold proc init rgx folder) |
| 315 | "Folds PROCEDURE over bindings matching third arg REGEXP. |
| 316 | |
| 317 | Result is |
| 318 | |
| 319 | (PROCEDURE MODULE1 NAME1 VALUE1 |
| 320 | (PROCEDURE MODULE2 NAME2 VALUE2 |
| 321 | ... |
| 322 | (PROCEDURE MODULEn NAMEn VALUEn INIT))) |
| 323 | |
| 324 | where INIT is the second arg to `apropos-fold'. |
| 325 | |
| 326 | Fourth arg FOLDER is one of |
| 327 | |
| 328 | (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE |
| 329 | apropos-fold-exported ;fold over all exported bindings |
| 330 | apropos-fold-all ;fold over all bindings" |
| 331 | (let ((match (make-regexp rgx)) |
| 332 | (recorded (make-vector 61 '()))) |
| 333 | (let ((fold-module |
| 334 | (lambda (module data) |
| 335 | (let* ((obarray-filter |
| 336 | (lambda (name val data) |
| 337 | (if (and (regexp-exec match (symbol->string name)) |
| 338 | (not (hashq-get-handle recorded name))) |
| 339 | (begin |
| 340 | (hashq-set! recorded name #t) |
| 341 | (proc module name val data)) |
| 342 | data))) |
| 343 | (module-filter |
| 344 | (lambda (name var data) |
| 345 | (if (variable-bound? var) |
| 346 | (obarray-filter name (variable-ref var) data) |
| 347 | data)))) |
| 348 | (cond (module (hash-fold module-filter |
| 349 | data |
| 350 | (module-obarray module))) |
| 351 | (else data)))))) |
| 352 | (folder fold-module init)))) |
| 353 | |
| 354 | (define (make-fold-modules init-thunk traverse extract) |
| 355 | "Return procedure capable of traversing a forest of modules. |
| 356 | The forest traversed is the image of the forest generated by root |
| 357 | modules returned by INIT-THUNK and the generator TRAVERSE. |
| 358 | It is an image under the mapping EXTRACT." |
| 359 | (lambda (fold-module init) |
| 360 | (let* ((table (make-hash-table 31)) |
| 361 | (first? (lambda (obj) |
| 362 | (let* ((handle (hash-create-handle! table obj #t)) |
| 363 | (first? (cdr handle))) |
| 364 | (set-cdr! handle #f) |
| 365 | first?)))) |
| 366 | (let rec ((data init) |
| 367 | (modules (init-thunk))) |
| 368 | (do ((modules modules (cdr modules)) |
| 369 | (data data (if (first? (car modules)) |
| 370 | (rec (fold-module (extract (car modules)) data) |
| 371 | (traverse (car modules))) |
| 372 | data))) |
| 373 | ((null? modules) data)))))) |
| 374 | |
| 375 | (define (apropos-fold-accessible module) |
| 376 | (make-fold-modules (lambda () (list module)) |
| 377 | module-uses |
| 378 | identity)) |
| 379 | |
| 380 | (define (root-modules) |
| 381 | (cons the-root-module |
| 382 | (submodules (nested-ref the-root-module '(app modules))))) |
| 383 | |
| 384 | (define (submodules m) |
| 385 | (hash-fold (lambda (name var data) |
| 386 | (let ((obj (and (variable-bound? var) (variable-ref var)))) |
| 387 | (if (and (module? obj) |
| 388 | (eq? (module-kind obj) 'directory)) |
| 389 | (cons obj data) |
| 390 | data))) |
| 391 | '() |
| 392 | (module-obarray m))) |
| 393 | |
| 394 | (define apropos-fold-exported |
| 395 | (make-fold-modules root-modules submodules module-public-interface)) |
| 396 | |
| 397 | (define apropos-fold-all |
| 398 | (make-fold-modules root-modules submodules identity)) |
| 399 | |
| 400 | (define (source obj) |
| 401 | (cond ((procedure? obj) (procedure-source obj)) |
| 402 | ((macro? obj) (procedure-source (macro-transformer obj))) |
| 403 | (else #f))) |
| 404 | |
| 405 | (define (arity obj) |
| 406 | (define (display-arg-list arg-list) |
| 407 | (display #\`) |
| 408 | (display (car arg-list)) |
| 409 | (let loop ((ls (cdr arg-list))) |
| 410 | (cond ((null? ls) |
| 411 | (display #\')) |
| 412 | ((not (pair? ls)) |
| 413 | (display "', the rest in `") |
| 414 | (display ls) |
| 415 | (display #\')) |
| 416 | (else |
| 417 | (if (pair? (cdr ls)) |
| 418 | (display "', `") |
| 419 | (display "' and `")) |
| 420 | (display (car ls)) |
| 421 | (loop (cdr ls)))))) |
| 422 | (define (display-arg-list/summary arg-list type) |
| 423 | (let ((len (length arg-list))) |
| 424 | (display len) |
| 425 | (display " ") |
| 426 | (display type) |
| 427 | (if (> len 1) |
| 428 | (display " arguments: ") |
| 429 | (display " argument: ")) |
| 430 | (display-arg-list arg-list))) |
| 431 | (cond |
| 432 | ((procedure-property obj 'arglist) |
| 433 | => (lambda (arglist) |
| 434 | (let ((required-args (car arglist)) |
| 435 | (optional-args (cadr arglist)) |
| 436 | (keyword-args (caddr arglist)) |
| 437 | (allow-other-keys? (cadddr arglist)) |
| 438 | (rest-arg (car (cddddr arglist))) |
| 439 | (need-punctuation #f)) |
| 440 | (cond ((not (null? required-args)) |
| 441 | (display-arg-list/summary required-args "required") |
| 442 | (set! need-punctuation #t))) |
| 443 | (cond ((not (null? optional-args)) |
| 444 | (if need-punctuation (display ", ")) |
| 445 | (display-arg-list/summary optional-args "optional") |
| 446 | (set! need-punctuation #t))) |
| 447 | (cond ((not (null? keyword-args)) |
| 448 | (if need-punctuation (display ", ")) |
| 449 | (display-arg-list/summary keyword-args "keyword") |
| 450 | (set! need-punctuation #t))) |
| 451 | (cond (allow-other-keys? |
| 452 | (if need-punctuation (display ", ")) |
| 453 | (display "other keywords allowed") |
| 454 | (set! need-punctuation #t))) |
| 455 | (cond (rest-arg |
| 456 | (if need-punctuation (display ", ")) |
| 457 | (display "the rest in `") |
| 458 | (display rest-arg) |
| 459 | (display "'")))))) |
| 460 | (else |
| 461 | (let ((arity (procedure-property obj 'arity))) |
| 462 | (display (car arity)) |
| 463 | (cond ((caddr arity) |
| 464 | (display " or more")) |
| 465 | ((not (zero? (cadr arity))) |
| 466 | (display " required and ") |
| 467 | (display (cadr arity)) |
| 468 | (display " optional"))) |
| 469 | (if (and (not (caddr arity)) |
| 470 | (= (car arity) 1) |
| 471 | (<= (cadr arity) 1)) |
| 472 | (display " argument") |
| 473 | (display " arguments")) |
| 474 | (if (closure? obj) |
| 475 | (let ((formals (cadr (procedure-source obj)))) |
| 476 | (cond |
| 477 | ((pair? formals) |
| 478 | (display ": ") |
| 479 | (display-arg-list formals)) |
| 480 | (else |
| 481 | (display " in `") |
| 482 | (display formals) |
| 483 | (display #\')))))))) |
| 484 | (display ".\n")) |
| 485 | |
| 486 | (define system-module |
| 487 | (procedure->syntax |
| 488 | (lambda (exp env) |
| 489 | (let* ((m (nested-ref the-root-module |
| 490 | (append '(app modules) (cadr exp))))) |
| 491 | (if (not m) |
| 492 | (error "Couldn't find any module named" (cadr exp))) |
| 493 | (let ((s (not (procedure-property (module-eval-closure m) |
| 494 | 'system-module)))) |
| 495 | (set-system-module! m s) |
| 496 | (string-append "Module " (symbol->string (module-name m)) |
| 497 | " is now a " (if s "system" "user") " module.")))))) |
| 498 | |
| 499 | ;;; session.scm ends here |