ice-9/session.scm

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