:use-module (ice-9 documentation)
:use-module (ice-9 regex)
:use-module (ice-9 rdelim)
- :export (help apropos apropos-internal apropos-fold
- apropos-fold-accessible apropos-fold-exported apropos-fold-all
- source arity procedure-arguments))
+ :export (help
+ add-value-help-handler! remove-value-help-handler!
+ add-name-help-handler! remove-name-help-handler!
+ apropos apropos-internal apropos-fold apropos-fold-accessible
+ apropos-fold-exported apropos-fold-all source arity
- system-module module-commentary))
++ procedure-arguments
++ module-commentary))
\f
+ (define *value-help-handlers*
+ `(,(lambda (name value)
+ (object-documentation value))))
+
+ (define (add-value-help-handler! proc)
+ "Adds a handler for performing `help' on a value.
+
+ `proc' will be called as (PROC NAME VALUE). `proc' should return #t to
+ indicate that it has performed help, a string to override the default
+ object documentation, or #f to try the other handlers, potentially
+ falling back on the normal behavior for `help'."
+ (set! *value-help-handlers* (cons proc *value-help-handlers*)))
+
+ (define (remove-value-help-handler! proc)
+ "Removes a handler for performing `help' on a value."
+ (set! *value-help-handlers* (delete! proc *value-help-handlers*)))
+
+ (define (try-value-help name value)
+ (or-map (lambda (proc) (proc name value)) *value-help-handlers*))
+
+
+ (define *name-help-handlers* '())
+
+ (define (add-name-help-handler! proc)
+ "Adds a handler for performing `help' on a name.
+
+ `proc' will be called with the unevaluated name as its argument. That is
+ to say, when the user calls `(help FOO)', the name is FOO, exactly as
+ the user types it.
+
+ `proc' should return #t to indicate that it has performed help, a string
+ to override the default object documentation, or #f to try the other
+ handlers, potentially falling back on the normal behavior for `help'."
+ (set! *name-help-handlers* (cons proc *name-help-handlers*)))
+
+ (define (remove-name-help-handler! proc)
+ "Removes a handler for performing `help' on a name."
+ (set! *name-help-handlers* (delete! proc *name-help-handlers*)))
+
+ (define (try-name-help name)
+ (or-map (lambda (proc) (proc name)) *name-help-handlers*))
+
+
;;; Documentation
;;;
-(define help
- (procedure->syntax
- (lambda (exp env)
- "(help [NAME])
+(define-macro (help . exp)
+ "(help [NAME])
Prints useful information. Try `(help)'."
- (cond ((not (= (length exp) 2))
- (help-usage))
- ((not (provided? 'regex))
- (display "`help' depends on the `regex' feature.
-You don't seem to have regular expressions installed.\n"))
+ (cond ((not (= (length exp) 1))
+ (help-usage)
+ '(begin))
+ ((not (provided? 'regex))
+ (display "`help' depends on the `regex' feature.
+You don't seem to have regular expressions installed.\n")
+ '(begin))
+ (else
+ (let ((name (car exp))
+ (not-found (lambda (type x)
+ (simple-format #t "No ~A found for ~A\n"
+ type x))))
+ (cond
+
++ ;; User-specified
++ ((try-name-help name)
++ => (lambda (x) (if (not (eq? x #t)) (display x))))
++
+ ;; SYMBOL
+ ((symbol? name)
+ (help-doc name
+ (simple-format
+ #f "^~A$"
+ (regexp-quote (symbol->string name)))))
+
+ ;; "STRING"
+ ((string? name)
+ (help-doc name name))
+
+ ;; (unquote SYMBOL)
+ ((and (list? name)
+ (= (length name) 2)
+ (eq? (car name) 'unquote))
- (cond ((object-documentation
- (eval (cadr name) (current-module)))
- => write-line)
- (else (not-found 'documentation (cadr name)))))
++ (let ((doc (try-value-help (cadr name)
++ (local-eval (cadr name) env))))
++ (cond ((not doc) (not-found 'documentation (cadr name)))
++ ((eq? doc #t)) ;; pass
++ (else (write-line doc)))))
+
+ ;; (quote SYMBOL)
+ ((and (list? name)
+ (= (length name) 2)
+ (eq? (car name) 'quote)
+ (symbol? (cadr name)))
+ (cond ((search-documentation-files (cadr name))
+ => write-line)
+ (else (not-found 'documentation (cadr name)))))
+
+ ;; (SYM1 SYM2 ...)
+ ((and (list? name)
+ (and-map symbol? name)
+ (not (null? name))
+ (not (eq? (car name) 'quote)))
+ (cond ((module-commentary name)
+ => (lambda (doc)
+ (display name) (write-line " commentary:")
+ (write-line doc)))
+ (else (not-found 'commentary name))))
+
+ ;; unrecognized
(else
- (let ((name (cadr exp))
- (not-found (lambda (type x)
- (simple-format #t "No ~A found for ~A\n"
- type x))))
- (cond
-
- ;; User-specified
- ((try-name-help name)
- => (lambda (x) (if (not (eq? x #t)) (display x))))
-
- ;; SYMBOL
- ((symbol? name)
- (help-doc name
- (simple-format
- #f "^~A$"
- (regexp-quote (symbol->string name)))))
-
- ;; "STRING"
- ((string? name)
- (help-doc name name))
-
- ;; (unquote SYMBOL)
- ((and (list? name)
- (= (length name) 2)
- (eq? (car name) 'unquote))
- (let ((doc (try-value-help (cadr name)
- (local-eval (cadr name) env))))
- (cond ((not doc) (not-found 'documentation (cadr name)))
- ((eq? doc #t)) ;; pass
- (else (write-line doc)))))
-
- ;; (quote SYMBOL)
- ((and (list? name)
- (= (length name) 2)
- (eq? (car name) 'quote)
- (symbol? (cadr name)))
- (cond ((search-documentation-files (cadr name))
- => write-line)
- (else (not-found 'documentation (cadr name)))))
-
- ;; (SYM1 SYM2 ...)
- ((and (list? name)
- (and-map symbol? name)
- (not (null? name))
- (not (eq? (car name) 'quote)))
- (cond ((module-commentary name)
- => (lambda (doc)
- (display name) (write-line " commentary:")
- (write-line doc)))
- (else (not-found 'commentary name))))
-
- ;; unrecognized
- (else
- (help-usage)))
- *unspecified*))))))
+ (help-usage)))
+ '(begin)))))
(define (module-filename name) ; fixme: better way? / done elsewhere?
(let* ((name (map symbol->string name))
HCoop / bpt / guile.git / commitdiff