ice-9/session.scm

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