guile18/ice-9/session.scm

   1 ;;;;    Copyright (C) 1997, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library 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 GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (ice-9 session)
  20   :use-module (ice-9 documentation)
  21   :use-module (ice-9 regex)
  22   :use-module (ice-9 rdelim)
  23   :export (help
  24            add-value-help-handler! remove-value-help-handler!
  25            add-name-help-handler! remove-name-help-handler!
  26            apropos apropos-internal apropos-fold apropos-fold-accessible
  27            apropos-fold-exported apropos-fold-all source arity
  28            system-module module-commentary))
  29
  30 \f
  31
  32 (define *value-help-handlers*
  33   `(,(lambda (name value)
  34        (object-documentation value))))
  35
  36 (define (add-value-help-handler! proc)
  37   "Adds a handler for performing `help' on a value.
  38
  39 `proc' will be called as (PROC NAME VALUE). `proc' should return #t to
  40 indicate that it has performed help, a string to override the default
  41 object documentation, or #f to try the other handlers, potentially
  42 falling back on the normal behavior for `help'."
  43   (set! *value-help-handlers* (cons proc *value-help-handlers*)))
  44
  45 (define (remove-value-help-handler! proc)
  46   "Removes a handler for performing `help' on a value."
  47   (set! *value-help-handlers* (delete! proc *value-help-handlers*)))
  48
  49 (define (try-value-help name value)
  50   (or-map (lambda (proc) (proc name value)) *value-help-handlers*))
  51
  52
  53 (define *name-help-handlers* '())
  54
  55 (define (add-name-help-handler! proc)
  56   "Adds a handler for performing `help' on a name.
  57
  58 `proc' will be called with the unevaluated name as its argument. That is
  59 to say, when the user calls `(help FOO)', the name is FOO, exactly as
  60 the user types it.
  61
  62 `proc' should return #t to indicate that it has performed help, a string
  63 to override the default object documentation, or #f to try the other
  64 handlers, potentially falling back on the normal behavior for `help'."
  65   (set! *name-help-handlers* (cons proc *name-help-handlers*)))
  66
  67 (define (remove-name-help-handler! proc)
  68   "Removes a handler for performing `help' on a name."
  69   (set! *name-help-handlers* (delete! proc *name-help-handlers*)))
  70
  71 (define (try-name-help name)
  72   (or-map (lambda (proc) (proc name)) *name-help-handlers*))
  73
  74
  75 ;;; Documentation
  76 ;;;
  77 (define help
  78   (procedure->syntax
  79     (lambda (exp env)
  80       "(help [NAME])
  81 Prints useful information.  Try `(help)'."
  82       (cond ((not (= (length exp) 2))
  83              (help-usage))
  84             ((not (provided? 'regex))
  85              (display "`help' depends on the `regex' feature.
  86 You don't seem to have regular expressions installed.\n"))
  87             (else
  88              (let ((name (cadr exp))
  89                    (not-found (lambda (type x)
  90                                 (simple-format #t "No ~A found for ~A\n"
  91                                                type x))))
  92                (cond
  93
  94                 ;; User-specified
  95                 ((try-name-help name)
  96                  => (lambda (x) (if (not (eq? x #t)) (display x))))
  97
  98                 ;; SYMBOL
  99                 ((symbol? name)
 100                  (help-doc name
 101                            (simple-format
 102                             #f "^~A$"
 103                             (regexp-quote (symbol->string name)))))
 104
 105                 ;; "STRING"
 106                 ((string? name)
 107                  (help-doc name name))
 108
 109                 ;; (unquote SYMBOL)
 110                 ((and (list? name)
 111                       (= (length name) 2)
 112                       (eq? (car name) 'unquote))
 113                  (let ((doc (try-value-help (cadr name)
 114                                             (local-eval (cadr name) env))))
 115                    (cond ((not doc) (not-found 'documentation (cadr name)))
 116                          ((eq? doc #t)) ;; pass
 117                          (else (write-line doc)))))
 118
 119                 ;; (quote SYMBOL)
 120                 ((and (list? name)
 121                       (= (length name) 2)
 122                       (eq? (car name) 'quote)
 123                       (symbol? (cadr name)))
 124                  (cond ((search-documentation-files (cadr name))
 125                         => write-line)
 126                        (else (not-found 'documentation (cadr name)))))
 127
 128                 ;; (SYM1 SYM2 ...)
 129                 ((and (list? name)
 130                       (and-map symbol? name)
 131                       (not (null? name))
 132                       (not (eq? (car name) 'quote)))
 133                  (cond ((module-commentary name)
 134                         => (lambda (doc)
 135                              (display name) (write-line " commentary:")
 136                              (write-line doc)))
 137                        (else (not-found 'commentary name))))
 138
 139                 ;; unrecognized
 140                 (else
 141                  (help-usage)))
 142                *unspecified*))))))
 143
 144 (define (module-filename name)          ; fixme: better way? / done elsewhere?
 145   (let* ((name (map symbol->string name))
 146          (reverse-name (reverse name))
 147          (leaf (car reverse-name))
 148          (dir-hint-module-name (reverse (cdr reverse-name)))
 149          (dir-hint (apply string-append
 150                           (map (lambda (elt)
 151                                  (string-append elt "/"))
 152                                dir-hint-module-name))))
 153     (%search-load-path (in-vicinity dir-hint leaf))))
 154
 155 (define (module-commentary name)
 156   (cond ((module-filename name) => file-commentary)
 157         (else #f)))
 158
 159 (define (help-doc term regexp)
 160   (let ((entries (apropos-fold (lambda (module name object data)
 161                                  (cons (list module
 162                                              name
 163                                              (try-value-help name object)
 164                                              (cond ((closure? object)
 165                                                     "a procedure")
 166                                                    ((procedure? object)
 167                                                     "a primitive procedure")
 168                                                    (else
 169                                                     "an object")))
 170                                        data))
 171                                '()
 172                                regexp
 173                                apropos-fold-exported))
 174         (module car)
 175         (name cadr)
 176         (doc caddr)
 177         (type cadddr))
 178     (cond ((not (null? entries))
 179            (let ((first? #t)
 180                  (undocumented-entries '())
 181                  (documented-entries '())
 182                  (documentations '()))
 183
 184              (for-each (lambda (entry)
 185                          (let ((entry-summary (simple-format
 186                                                #f "~S: ~S\n"
 187                                                (module-name (module entry))
 188                                                (name entry))))
 189                            (if (doc entry)
 190                                (begin
 191                                  (set! documented-entries
 192                                        (cons entry-summary documented-entries))
 193                                  ;; *fixme*: Use `describe' when we have GOOPS?
 194                                  (set! documentations
 195                                        (cons (simple-format
 196                                               #f "`~S' is ~A in the ~S module.\n\n~A\n"
 197                                               (name entry)
 198                                               (type entry)
 199                                               (module-name (module entry))
 200                                               (doc entry))
 201                                              documentations)))
 202                                (set! undocumented-entries
 203                                      (cons entry-summary
 204                                            undocumented-entries)))))
 205                        entries)
 206
 207              (if (and (not (null? documented-entries))
 208                       (or (> (length documented-entries) 1)
 209                           (not (null? undocumented-entries))))
 210                  (begin
 211                    (display "Documentation found for:\n")
 212                    (for-each (lambda (entry) (display entry))
 213                              documented-entries)
 214                    (set! first? #f)))
 215
 216              (for-each (lambda (entry)
 217                          (if first?
 218                              (set! first? #f)
 219                              (newline))
 220                          (display entry))
 221                        documentations)
 222
 223              (if (not (null? undocumented-entries))
 224                  (begin
 225                    (if first?
 226                        (set! first? #f)
 227                        (newline))
 228                    (display "No documentation found for:\n")
 229                    (for-each (lambda (entry) (display entry))
 230                              undocumented-entries)))))
 231           ((search-documentation-files term)
 232            => (lambda (doc)
 233                 (write-line "Documentation from file:")
 234                 (write-line doc)))
 235           (else
 236            ;; no matches
 237            (display "Did not find any object ")
 238            (simple-format #t
 239                           (if (symbol? term)
 240                               "named `~A'\n"
 241                               "matching regexp \"~A\"\n")
 242                           term)))))
 243
 244 (define (help-usage)
 245   (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
 246        (help REGEXP) ditto for objects with names matching REGEXP (a string)
 247        (help 'NAME) gives documentation for NAME, even if it is not an object
 248        (help ,EXPR) gives documentation for object returned by EXPR
 249        (help (my module)) gives module commentary for `(my module)'
 250        (help) gives this text
 251
 252 `help' searches among bindings exported from loaded modules, while
 253 `apropos' searches among bindings visible from the \"current\" module.
 254
 255 Examples: (help help)
 256           (help cons)
 257           (help \"output-string\")
 258
 259 Other useful sources of helpful information:
 260
 261 (apropos STRING)
 262 (arity PROCEDURE)
 263 (name PROCEDURE-OR-MACRO)
 264 (source PROCEDURE-OR-MACRO)
 265
 266 Tools:
 267
 268 (backtrace)                             ;show backtrace from last error
 269 (debug)                                 ;enter the debugger
 270 (trace [PROCEDURE])                     ;trace procedure (no arg => show)
 271 (untrace [PROCEDURE])                   ;untrace (no arg => untrace all)
 272
 273 (OPTIONSET-options 'full)               ;display option information
 274 (OPTIONSET-enable 'OPTION)
 275 (OPTIONSET-disable 'OPTION)
 276 (OPTIONSET-set! OPTION VALUE)
 277
 278 where OPTIONSET is one of debug, read, eval, print
 279
 280 "))
 281
 282 ;;; {Apropos}
 283 ;;;
 284 ;;; Author: Roland Orre <orre@nada.kth.se>
 285 ;;;
 286
 287 (define (apropos rgx . options)
 288   "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
 289   (if (zero? (string-length rgx))
 290       "Empty string not allowed"
 291       (let* ((match (make-regexp rgx))
 292              (uses (module-uses (current-module)))
 293              (modules (cons (current-module)
 294                             (if (and (not (null? uses))
 295                                      (eq? (module-name (car uses))
 296                                           'duplicates))
 297                                 (cdr uses)
 298                                 uses)))
 299              (separator #\tab)
 300              (shadow (member 'shadow options))
 301              (value (member 'value options)))
 302         (cond ((member 'full options)
 303                (set! shadow #t)
 304                (set! value #t)))
 305         (for-each
 306          (lambda (module)
 307            (let* ((name (module-name module))
 308                   (obarray (module-obarray module)))
 309              ;; XXX - should use hash-fold here
 310              (hash-for-each
 311               (lambda (symbol variable)
 312                 (cond ((regexp-exec match (symbol->string symbol))
 313                        (display name)
 314                        (display ": ")
 315                        (display symbol)
 316                        (cond ((variable-bound? variable)
 317                               (let ((val (variable-ref variable)))
 318                                 (cond ((or (procedure? val) value)
 319                                        (display separator)
 320                                        (display val)))))
 321                              (else
 322                               (display separator)
 323                               (display "(unbound)")))
 324                        (if (and shadow
 325                                 (not (eq? (module-ref module symbol)
 326                                           (module-ref (current-module) symbol))))
 327                            (display " shadowed"))
 328                        (newline))))
 329               obarray)))
 330          modules))))
 331
 332 (define (apropos-internal rgx)
 333   "Return a list of accessible variable names."
 334   (apropos-fold (lambda (module name var data)
 335                   (cons name data))
 336                 '()
 337                 rgx
 338                 (apropos-fold-accessible (current-module))))
 339
 340 (define (apropos-fold proc init rgx folder)
 341   "Folds PROCEDURE over bindings matching third arg REGEXP.
 342
 343 Result is
 344
 345   (PROCEDURE MODULE1 NAME1 VALUE1
 346     (PROCEDURE MODULE2 NAME2 VALUE2
 347       ...
 348       (PROCEDURE MODULEn NAMEn VALUEn INIT)))
 349
 350 where INIT is the second arg to `apropos-fold'.
 351
 352 Fourth arg FOLDER is one of
 353
 354   (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
 355   apropos-fold-exported            ;fold over all exported bindings
 356   apropos-fold-all                 ;fold over all bindings"
 357   (let ((match (make-regexp rgx))
 358         (recorded (make-vector 61 '())))
 359     (let ((fold-module
 360            (lambda (module data)
 361              (let* ((obarray-filter
 362                      (lambda (name val data)
 363                        (if (and (regexp-exec match (symbol->string name))
 364                                 (not (hashq-get-handle recorded name)))
 365                            (begin
 366                              (hashq-set! recorded name #t)
 367                              (proc module name val data))
 368                            data)))
 369                     (module-filter
 370                      (lambda (name var data)
 371                        (if (variable-bound? var)
 372                            (obarray-filter name (variable-ref var) data)
 373                            data))))
 374                (cond (module (hash-fold module-filter
 375                                         data
 376                                         (module-obarray module)))
 377                      (else data))))))
 378       (folder fold-module init))))
 379
 380 (define (make-fold-modules init-thunk traverse extract)
 381   "Return procedure capable of traversing a forest of modules.
 382 The forest traversed is the image of the forest generated by root
 383 modules returned by INIT-THUNK and the generator TRAVERSE.
 384 It is an image under the mapping EXTRACT."
 385   (lambda (fold-module init)
 386     (let* ((table (make-hash-table 31))
 387            (first? (lambda (obj)
 388                      (let* ((handle (hash-create-handle! table obj #t))
 389                             (first? (cdr handle)))
 390                        (set-cdr! handle #f)
 391                        first?))))
 392       (let rec ((data init)
 393                 (modules (init-thunk)))
 394         (do ((modules modules (cdr modules))
 395              (data data (if (first? (car modules))
 396                             (rec (fold-module (extract (car modules)) data)
 397                                  (traverse (car modules)))
 398                             data)))
 399             ((null? modules) data))))))
 400
 401 (define (apropos-fold-accessible module)
 402   (make-fold-modules (lambda () (list module))
 403                      module-uses
 404                      identity))
 405
 406 (define (root-modules)
 407   (cons the-root-module
 408         (submodules (nested-ref the-root-module '(app modules)))))
 409
 410 (define (submodules m)
 411   (hash-fold (lambda (name var data)
 412                (let ((obj (and (variable-bound? var) (variable-ref var))))
 413                  (if (and (module? obj)
 414                           (eq? (module-kind obj) 'directory))
 415                      (cons obj data)
 416                      data)))
 417              '()
 418              (module-obarray m)))
 419
 420 (define apropos-fold-exported
 421   (make-fold-modules root-modules submodules module-public-interface))
 422
 423 (define apropos-fold-all
 424   (make-fold-modules root-modules submodules identity))
 425
 426 (define (source obj)
 427   (cond ((procedure? obj) (procedure-source obj))
 428         ((macro? obj) (procedure-source (macro-transformer obj)))
 429         (else #f)))
 430
 431 (define (arity obj)
 432   (define (display-arg-list arg-list)
 433     (display #\`)
 434     (display (car arg-list))
 435     (let loop ((ls (cdr arg-list)))
 436       (cond ((null? ls)
 437              (display #\'))
 438             ((not (pair? ls))
 439              (display "', the rest in `")
 440              (display ls)
 441              (display #\'))
 442             (else
 443              (if (pair? (cdr ls))
 444                  (display "', `")
 445                  (display "' and `"))
 446              (display (car ls))
 447              (loop (cdr ls))))))
 448   (define (display-arg-list/summary arg-list type)
 449     (let ((len (length arg-list)))
 450       (display len)
 451       (display " ")
 452       (display type)
 453       (if (> len 1)
 454           (display " arguments: ")
 455           (display " argument: "))
 456       (display-arg-list arg-list)))
 457   (cond
 458    ((procedure-property obj 'arglist)
 459     => (lambda (arglist)
 460          (let ((required-args (car arglist))
 461                (optional-args (cadr arglist))
 462                (keyword-args (caddr arglist))
 463                (allow-other-keys? (cadddr arglist))
 464                (rest-arg (car (cddddr arglist)))
 465                (need-punctuation #f))
 466            (cond ((not (null? required-args))
 467                   (display-arg-list/summary required-args "required")
 468                   (set! need-punctuation #t)))
 469            (cond ((not (null? optional-args))
 470                   (if need-punctuation (display ", "))
 471                   (display-arg-list/summary optional-args "optional")
 472                   (set! need-punctuation #t)))
 473            (cond ((not (null? keyword-args))
 474                   (if need-punctuation (display ", "))
 475                   (display-arg-list/summary keyword-args "keyword")
 476                   (set! need-punctuation #t)))
 477            (cond (allow-other-keys?
 478                   (if need-punctuation (display ", "))
 479                   (display "other keywords allowed")
 480                   (set! need-punctuation #t)))
 481            (cond (rest-arg
 482                   (if need-punctuation (display ", "))
 483                   (display "the rest in `")
 484                   (display rest-arg)
 485                   (display "'"))))))
 486    (else
 487     (let ((arity (procedure-property obj 'arity)))
 488       (display (car arity))
 489       (cond ((caddr arity)
 490              (display " or more"))
 491             ((not (zero? (cadr arity)))
 492              (display " required and ")
 493              (display (cadr arity))
 494              (display " optional")))
 495       (if (and (not (caddr arity))
 496                (= (car arity) 1)
 497                (<= (cadr arity) 1))
 498           (display " argument")
 499           (display " arguments"))
 500       (if (closure? obj)
 501           (let ((formals (cadr (procedure-source obj))))
 502             (cond
 503              ((pair? formals)
 504               (display ": ")
 505               (display-arg-list formals))
 506              (else
 507               (display " in `")
 508               (display formals)
 509               (display #\'))))))))
 510   (display ".\n"))
 511
 512 (define system-module
 513   (procedure->syntax
 514    (lambda (exp env)
 515      (let* ((m (nested-ref the-root-module
 516                            (append '(app modules) (cadr exp)))))
 517        (if (not m)
 518            (error "Couldn't find any module named" (cadr exp)))
 519        (let ((s (not (procedure-property (module-eval-closure m)
 520                                          'system-module))))
 521          (set-system-module! m s)
 522          (string-append "Module " (symbol->string (module-name m))
 523                         " is now a " (if s "system" "user") " module."))))))
 524
 525 ;;; session.scm ends here