ice-9/session.scm

   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