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