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