module/ice-9/session.scm

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