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-weak-bindings)
 203                                       (builtin-bindings))
 204                                 (list (module-obarray module))))
 205                   (get-refs (if builtin
 206                                 (list id id)
 207                                 (list variable-ref)))
 208                   )
 209              (for-each
 210               (lambda (obarray get-ref)
 211                 (array-for-each
 212                  (lambda (oblist)
 213                    (for-each
 214                     (lambda (x)
 215                       (cond ((regexp-exec match (symbol->string (car x)))
 216                              (display name)
 217                              (display ": ")
 218                              (display (car x))
 219                              (cond ((procedure? (get-ref (cdr x)))
 220                                     (display separator)
 221                                     (display (get-ref (cdr x))))
 222                                    (value
 223                                     (display separator)
 224                                     (display (get-ref (cdr x)))))
 225                              (if (and shadow
 226                                       (not (eq? (module-ref module
 227                                                             (car x))
 228                                                 (module-ref (current-module)
 229                                                             (car x)))))
 230                                  (display " shadowed"))
 231                              (newline)
 232                              )))
 233                     oblist))
 234                  obarray))
 235               obarrays get-refs)))
 236          modules))))
 237
 238 (define-public (apropos-internal rgx)
 239   "Return a list of accessible variable names."
 240   (apropos-fold (lambda (module name var data)
 241                   (cons name data))
 242                 '()
 243                 rgx
 244                 (apropos-fold-accessible (current-module))))
 245
 246 (define-public (apropos-fold proc init rgx folder)
 247   "Folds PROCEDURE over bindings matching third arg REGEXP.
 248
 249 Result is
 250
 251   (PROCEDURE MODULE1 NAME1 VALUE1
 252     (PROCEDURE MODULE2 NAME2 VALUE2
 253       ...
 254       (PROCEDURE MODULEn NAMEn VALUEn INIT)))
 255
 256 where INIT is the second arg to `apropos-fold'.
 257
 258 Fourth arg FOLDER is one of
 259
 260   (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
 261   apropos-fold-exported            ;fold over all exported bindings
 262   apropos-fold-all                 ;fold over all bindings"
 263   (let ((match (make-regexp rgx))
 264         (recorded (make-vector 61 '())))
 265     (let ((fold-module
 266            (lambda (module data)
 267              (let* ((obarray-filter
 268                      (lambda (name val data)
 269                        (if (and (regexp-exec match (symbol->string name))
 270                                 (not (hashq-get-handle recorded name)))
 271                            (begin
 272                              (hashq-set! recorded name #t)
 273                              (proc module name val data))
 274                            data)))
 275                     (module-filter
 276                      (lambda (name var data)
 277                        (obarray-filter name (variable-ref var) data))))
 278                (cond ((or (eq? module the-scm-module)
 279                           (eq? module the-root-module))
 280                       (hash-fold obarray-filter
 281                                  (hash-fold obarray-filter
 282                                             data
 283                                             (builtin-bindings))
 284                                  (builtin-weak-bindings)))
 285                      (module (hash-fold module-filter
 286                                         data
 287                                         (module-obarray module)))
 288                      (else data))))))
 289       (folder fold-module init))))
 290
 291 (define (make-fold-modules init-thunk traverse extract)
 292   "Return procedure capable of traversing a forest of modules.
 293 The forest traversed is the image of the forest generated by root
 294 modules returned by INIT-THUNK and the generator TRAVERSE.
 295 It is an image under the mapping EXTRACT."
 296   (lambda (fold-module init)
 297     (let* ((table (make-hash-table 31))
 298            (first? (lambda (obj)
 299                      (let* ((handle (hash-create-handle! table obj #t))
 300                             (first? (cdr handle)))
 301                        (set-cdr! handle #f)
 302                        first?))))
 303       (let rec ((data init)
 304                 (modules (init-thunk)))
 305         (do ((modules modules (cdr modules))
 306              (data data (if (first? (car modules))
 307                             (rec (fold-module (extract (car modules)) data)
 308                                  (traverse (car modules)))
 309                             data)))
 310             ((null? modules) data))))))
 311
 312 (define-public (apropos-fold-accessible module)
 313   (make-fold-modules (lambda () (list module))
 314                      module-uses
 315                      (lambda (x) x)))
 316
 317 (define (root-modules)
 318   (cons the-root-module
 319         (submodules (nested-ref the-root-module '(app modules)))))
 320
 321 (define (submodules m)
 322   (hash-fold (lambda (name var data)
 323                (let ((obj (variable-ref var)))
 324                  (if (and (module? obj)
 325                           (eq? (module-kind obj) 'directory))
 326                      (cons obj data)
 327                      data)))
 328              '()
 329              (module-obarray m)))
 330
 331 (define-public apropos-fold-exported
 332   (make-fold-modules root-modules submodules module-public-interface))
 333
 334 (define-public apropos-fold-all
 335   (make-fold-modules root-modules submodules (lambda (x) x)))
 336
 337 (define-public (source obj)
 338   (cond ((procedure? obj) (procedure-source obj))
 339         ((macro? obj) (procedure-source (macro-transformer obj)))
 340         (else #f)))
 341
 342 (define-public (arity obj)
 343   (let ((arity (procedure-property obj 'arity)))
 344     (display (car arity))
 345     (cond ((caddr arity)
 346            (display " or more"))
 347           ((not (zero? (cadr arity)))
 348            (display " required and ")
 349            (display (cadr arity))
 350            (display " optional")))
 351     (if (and (not (caddr arity))
 352              (= (car arity) 1)
 353              (<= (cadr arity) 1))
 354         (display " argument")
 355         (display " arguments"))
 356     (if (closure? obj)
 357         (let ((formals (cadr (procedure-source obj))))
 358           (if (pair? formals)
 359               (begin
 360                 (display ": `")
 361                 (display (car formals))
 362                 (let loop ((ls (cdr formals)))
 363                   (cond ((null? ls)
 364                          (display #\'))
 365                         ((not (pair? ls))
 366                          (display "', the rest in `")
 367                          (display ls)
 368                          (display #\'))
 369                         (else
 370                          (if (pair? (cdr ls))
 371                              (display "', `")
 372                              (display "' and `"))
 373                          (display (car ls))
 374                          (loop (cdr ls))))))
 375               (begin
 376                 (display " in `")
 377                 (display formals)
 378                 (display #\')))))
 379     (display ".\n")))
 380
 381 (define-public system-module
 382   (procedure->syntax
 383    (lambda (exp env)
 384      (let* ((m (nested-ref the-root-module
 385                            (append '(app modules) (cadr exp)))))
 386        (if (not m)
 387            (error "Couldn't find any module named" (cadr exp)))
 388        (let ((s (not (procedure-property (module-eval-closure m)
 389                                          'system-module))))
 390          (set-system-module! m s)
 391          (string-append "Module " (symbol->string (module-name m))
 392                         " is now a " (if s "system" "user") " module."))))))