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