1 ;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.
3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1995 Sun Microsystems.
6 ;; Copyright (C) 1996 Ben Wing.
8 ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
9 ;; Keywords: lisp, tools, help, docs, matching
11 ;; This file is part of SXEmacs.
13 ;; SXEmacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; SXEmacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Synched up with: Not in FSF.
30 ;; based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
32 ;; Rather than run apropos and print all the documentation at once,
33 ;; I find it easier to view a "table of contents" first, then
34 ;; get the details for symbols as you need them.
36 ;; This version of apropos prints two lists of symbols matching the
37 ;; given regexp: functions/macros and variables/constants.
39 ;; The user can then do the following:
41 ;; - add an additional regexp to narrow the search
42 ;; - display documentation for the current symbol
43 ;; - find the tag for the current symbol
44 ;; - show any keybindings if the current symbol is a command
48 ;; An additional feature is the ability to search the current tags
49 ;; table, allowing you to interrogate functions not yet loaded (this
50 ;; isn't available with the standard package).
52 ;; Mouse bindings and menus are provided for XEmacs.
54 ;; additions by Ben Wing <ben@xemacs.org> July 1995:
55 ;; added support for function aliases, made programmer's apropos be the
56 ;; default, various other hacking.
57 ;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de>
58 ;; Some changes for XEmacs 20.3 by hniksic
60 ;; #### The maintainer is supposed to be stig, but I haven't seen him
61 ;; around for ages. The real maintainer for the moment is Hrvoje
62 ;; Niksic <hniksic@xemacs.org>.
67 (defgroup hyper-apropos nil
68 "Hypertext emacs lisp documentation interface."
75 (defcustom hyper-apropos-show-brief-docs t
76 "*If non-nil, display some documentation in the \"*Hyper Apropos*\" buffer.
77 Setting this to nil will speed up searches."
79 :group 'hyper-apropos)
80 (define-obsolete-variable-alias
81 'hypropos-show-brief-docs 'hyper-apropos-show-brief-docs)
82 ;; I changed this to true because I think it's more useful this way. --ben
84 (defcustom hyper-apropos-programming-apropos t
85 "*If non-nil, list all the functions and variables.
86 This will cause more output to be generated, and take a longer time.
88 Otherwise, only the interactive functions and user variables will be listed."
90 :group 'hyper-apropos)
91 (define-obsolete-variable-alias
92 'hypropos-programming-apropos 'hyper-apropos-programming-apropos)
94 (defcustom hyper-apropos-shrink-window nil
95 "*If non-nil, shrink *Hyper Help* buffer if possible."
97 :group 'hyper-apropos)
98 (define-obsolete-variable-alias
99 'hypropos-shrink-window 'hyper-apropos-shrink-window)
101 (defcustom hyper-apropos-prettyprint-long-values t
102 "*If non-nil, then try to beautify the printing of very long values."
104 :group 'hyper-apropos)
105 (define-obsolete-variable-alias
106 'hypropos-prettyprint-long-values 'hyper-apropos-prettyprint-long-values)
108 (defgroup hyper-apropos-faces nil
109 "Faces defined by hyper-apropos."
110 :prefix "hyper-apropos-"
113 (defface hyper-apropos-documentation
114 '((((class color) (background light))
115 (:foreground "darkred"))
116 (((class color) (background dark))
117 (:foreground "gray90")))
118 "Hyper-apropos documentation."
119 :group 'hyper-apropos-faces)
121 (defface hyper-apropos-hyperlink
122 '((((class color) (background light))
123 (:foreground "blue4"))
124 (((class color) (background dark))
125 (:foreground "lightseagreen"))
128 "Hyper-apropos hyperlinks."
129 :group 'hyper-apropos-faces)
131 (defface hyper-apropos-major-heading '((t (:bold t)))
132 "Hyper-apropos major heading."
133 :group 'hyper-apropos-faces)
135 (defface hyper-apropos-section-heading '((t (:bold t :italic t)))
136 "Hyper-apropos section heading."
137 :group 'hyper-apropos-faces)
139 (defface hyper-apropos-heading '((t (:bold t)))
140 "Hyper-apropos heading."
141 :group 'hyper-apropos-faces)
143 (defface hyper-apropos-warning '((t (:bold t :foreground "red")))
144 "Hyper-apropos warning."
145 :group 'hyper-apropos-faces)
147 ;;; Internal variables below this point
149 (defvar hyper-apropos-ref-buffer)
150 (defvar hyper-apropos-prev-wconfig)
152 (defvar hyper-apropos-help-map
153 (let ((map (make-sparse-keymap)))
154 (suppress-keymap map)
155 (set-keymap-name map 'hyper-apropos-help-map)
157 (define-key map " " 'scroll-up)
158 (define-key map "b" 'scroll-down)
159 (define-key map [delete] 'scroll-down)
160 (define-key map [backspace] 'scroll-down)
161 (define-key map "/" 'isearch-forward)
162 (define-key map "?" 'isearch-backward)
164 (define-key map [return] 'hyper-apropos-get-doc)
165 (define-key map "s" 'hyper-apropos-set-variable)
166 (define-key map "t" 'hyper-apropos-find-tag)
167 (define-key map "l" 'hyper-apropos-last-help)
168 (define-key map "c" 'hyper-apropos-customize-variable)
169 (define-key map "f" 'hyper-apropos-find-function)
170 (define-key map [button2] 'hyper-apropos-mouse-get-doc)
171 (define-key map [button3] 'hyper-apropos-popup-menu)
172 ;; for the totally hardcore...
173 (define-key map "D" 'hyper-apropos-disassemble)
175 (define-key map "a" 'hyper-apropos)
176 (define-key map "n" 'hyper-apropos)
177 (define-key map "q" 'hyper-apropos-quit)
179 "Keybindings for the *Hyper Help* buffer and the *Hyper Apropos* buffer")
180 (define-obsolete-variable-alias
181 'hypropos-help-map 'hyper-apropos-help-map)
183 (defvar hyper-apropos-map
184 (let ((map (make-sparse-keymap)))
185 (set-keymap-name map 'hyper-apropos-map)
186 (set-keymap-parents map (list hyper-apropos-help-map))
187 ;; slightly different scrolling...
188 (define-key map " " 'hyper-apropos-scroll-up)
189 (define-key map "b" 'hyper-apropos-scroll-down)
190 (define-key map [delete] 'hyper-apropos-scroll-down)
191 (define-key map [backspace] 'hyper-apropos-scroll-down)
192 ;; act on the current line...
193 (define-key map "w" 'hyper-apropos-where-is)
194 (define-key map "i" 'hyper-apropos-invoke-fn)
195 ;; this is already defined in the parent-keymap above, isn't it?
196 ;; (define-key map "s" 'hyper-apropos-set-variable)
197 ;; more administrativa...
198 (define-key map "P" 'hyper-apropos-toggle-programming-flag)
199 (define-key map "k" 'hyper-apropos-add-keyword)
200 (define-key map "e" 'hyper-apropos-eliminate-keyword)
202 "Keybindings for the *Hyper Apropos* buffer.
203 This map inherits from `hyper-apropos-help-map.'")
204 (define-obsolete-variable-alias
205 'hypropos-map 'hyper-apropos-map)
207 ;;(defvar hyper-apropos-mousable-keymap
208 ;; (let ((map (make-sparse-keymap)))
209 ;; (define-key map [button2] 'hyper-apropos-mouse-get-doc)
212 (defvar hyper-apropos-mode-hook nil
213 "*User function run after hyper-apropos mode initialization. Usage:
214 \(add-hook 'hyper-apropos-mode-hook #'(lambda () ... your init forms ...)).")
216 ;; ---------------------------------------------------------------------- ;;
218 (defconst hyper-apropos-junk-regexp
219 #r"^Apropos\|^Functions\|^Variables\|^$")
221 (defvar hyper-apropos-currently-showing nil) ; symbol documented in
223 (defvar hyper-apropos-help-history nil) ; chain of symbols followed as links in
225 (defvar hyper-apropos-face-history nil)
226 ;;;(defvar hyper-apropos-variable-history nil)
227 ;;;(defvar hyper-apropos-function-history nil)
228 (defvar hyper-apropos-regexp-history nil)
229 (defvar hyper-apropos-last-regexp nil) ; regex used for last apropos
230 (defconst hyper-apropos-apropos-buf "*Hyper Apropos*")
231 (defconst hyper-apropos-help-buf "*Hyper Help*")
234 (defun hyper-apropos (regexp toggle-apropos)
235 "Display lists of functions and variables matching REGEXP
236 in buffer \"*Hyper Apropos*\". If optional prefix arg is given, then the
237 value of `hyper-apropos-programming-apropos' is toggled for this search.
238 See also `hyper-apropos-mode'."
239 (interactive (list (read-from-minibuffer "List symbols matching regexp: "
240 nil nil nil 'hyper-apropos-regexp-history)
242 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
243 (setq hyper-apropos-prev-wconfig (current-window-configuration)))
244 (if (string= "" regexp)
245 (if (get-buffer hyper-apropos-apropos-buf)
247 (setq regexp hyper-apropos-last-regexp)
249 (hyper-apropos-toggle-programming-flag)
250 (message "Using last search results")))
251 (error "Be more specific..."))
252 (set-buffer (get-buffer-create hyper-apropos-apropos-buf))
253 (setq buffer-read-only nil)
256 (if (local-variable-p 'hyper-apropos-programming-apropos
258 (setq hyper-apropos-programming-apropos
259 (not hyper-apropos-programming-apropos))
260 (set (make-local-variable 'hyper-apropos-programming-apropos)
261 (not (default-value 'hyper-apropos-programming-apropos)))))
262 (let ((flist (apropos-internal regexp
263 (if hyper-apropos-programming-apropos
266 (vlist (apropos-internal regexp
267 (if hyper-apropos-programming-apropos
269 #'user-variable-p))))
270 (insert-face (format "Apropos search for: %S\n\n" regexp)
271 'hyper-apropos-major-heading)
272 (insert-face "* = command (M-x) or user-variable.\n"
273 'hyper-apropos-documentation)
274 (insert-face "a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n"
275 'hyper-apropos-documentation)
276 (insert-face "Functions and Macros:\n\n" 'hyper-apropos-major-heading)
277 (hyper-apropos-grok-functions flist)
278 (insert-face "\n\nVariables and Constants:\n\n"
279 'hyper-apropos-major-heading)
280 (hyper-apropos-grok-variables vlist)
281 (goto-char (point-min))))
282 (switch-to-buffer hyper-apropos-apropos-buf)
283 (hyper-apropos-mode regexp))
285 (defun hyper-apropos-toggle-programming-flag ()
287 (with-current-buffer hyper-apropos-apropos-buf
288 (set (make-local-variable 'hyper-apropos-programming-apropos)
289 (not hyper-apropos-programming-apropos)))
290 (message "Re-running apropos...")
291 (hyper-apropos hyper-apropos-last-regexp nil))
293 (defun hyper-apropos-grok-functions (fns)
296 (setq bind (symbol-function fn)
297 type (cond ((subrp bind) ?i)
298 ((compiled-function-p bind) ?b)
299 ((consp bind) (or (cdr
300 (assq (car bind) '((autoload . ?a)
305 (insert type (if (commandp fn) "* " " "))
306 (let ((e (insert-face (format "%S" fn) 'hyper-apropos-hyperlink)))
307 (set-extent-property e 'mouse-face 'highlight))
308 (insert-char ?\ (let ((l (- 30 (length (format "%S" fn)))))
309 (if (natnump l) l 0)))
310 (and hyper-apropos-show-brief-docs
312 ;; A symbol's function slot can point to an unbound symbol.
313 ;; In that case, `documentation' will fail.
316 (void-function "(alias for undefined function)")
317 (error "(unexpected error from `documentation')")))
319 "^([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
321 (setq doc (substring doc (match-end 0) (string-match "\n" doc)))
325 (substring doc 0 (string-match "\n" doc)))
327 'hyper-apropos-documentation))
330 (defun hyper-apropos-grok-variables (vars)
333 (setq userp (user-variable-p var))
334 (insert (if userp " * " " "))
335 (let ((e (insert-face (format "%S" var) 'hyper-apropos-hyperlink)))
336 (set-extent-property e 'mouse-face 'highlight))
337 (insert-char ?\ (let ((l (- 30 (length (format "%S" var)))))
338 (if (natnump l) l 0)))
339 (and hyper-apropos-show-brief-docs
340 (setq doc (documentation-property var 'variable-documentation))
342 (concat " - " (substring doc (if userp 1 0)
343 (string-match "\n" doc)))
344 " - Not documented.")
345 'hyper-apropos-documentation))
348 ;; ---------------------------------------------------------------------- ;;
350 (defun hyper-apropos-mode (regexp)
351 "Improved apropos mode for displaying Emacs documentation. Function and
352 variable names are displayed in the buffer \"*Hyper Apropos*\".
354 Functions are preceded by a single character to indicates their types:
355 a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
356 Interactive functions are also preceded by an asterisk.
357 Variables are preceded by an asterisk if they are user variables.
361 SPC - scroll documentation or apropos window forward
362 b - scroll documentation or apropos window backward
363 k - eliminate all hits that don't contain keyword
366 q - quit and restore previous window configuration
368 Operations for Symbol on Current Line:
370 RET - toggle display of symbol's documentation
371 (also on button2 in xemacs)
372 w - show the keybinding if symbol is a command
373 i - invoke function on current line
374 s - set value of variable on current line
375 t - display the C or lisp source (find-tag)"
376 (delete-other-windows)
377 (setq mode-name "Hyper-Apropos"
378 major-mode 'hyper-apropos-mode
381 hyper-apropos-last-regexp regexp
382 modeline-buffer-identification
383 (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ")
384 (cons modeline-buffer-id-right-extent (concat "\"" regexp "\""))))
385 (use-local-map hyper-apropos-map)
386 (run-hooks 'hyper-apropos-mode-hook))
388 ;; ---------------------------------------------------------------------- ;;
390 ;; similar to `describe-key-briefly', copied from help.el by CW
393 (defun hyper-describe-key (key)
394 (interactive "kDescribe key: ")
395 (hyper-describe-key-briefly key t))
398 (defun hyper-describe-key-briefly (key &optional show)
399 (interactive "kDescribe key briefly: \nP")
400 (let (menup defn interm final msg)
401 (setq defn (key-or-menu-binding key 'menup))
402 (if (or (null defn) (integerp defn))
403 (or (numberp show) (message "%s is undefined" (key-description key)))
404 (cond ((stringp defn)
406 final (key-binding defn)))
408 (setq interm (append defn nil))
410 (member (key-binding (vector (car interm)))
411 '(universal-argument digit-argument)))
412 (setq interm (cdr interm)))
414 (not (setq final (key-binding (vconcat interm)))))
415 (setq interm (butlast interm)))
417 (setq interm (vconcat interm))
419 final (key-binding defn)))))
422 ;; This used to say 'This menu item' but it could also
423 ;; be a scrollbar event. We can't distinguish at the
425 (if menup "This item" (key-description key))
426 ;;(if (symbolp defn) defn (key-description defn))
427 (if (symbolp defn) defn (prin1-to-string defn))
428 (if final (concat ", " (key-description interm) " runs ") "")
430 (if (symbolp final) final (prin1-to-string final))
433 (or (not (symbolp defn))
434 (memq (symbol-function defn)
435 '(zkey-init-kbd-macro zkey-init-kbd-fn))
436 (progn (princ msg) (princ "\n")))
438 (if final (setq defn final))
439 (if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn))))
442 (hyper-apropos-get-doc defn t))
443 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
444 (setq hyper-apropos-prev-wconfig (current-window-configuration)))))))
447 (defun hyper-describe-face (symbol &optional this-ref-buffer)
449 See also `hyper-apropos' and `hyper-describe-function'."
450 ;; #### - perhaps a prefix arg should suppress the prompt...
453 (setq v (hyper-apropos-this-symbol)) ; symbol under point
455 (setq v (variable-at-point)))
456 (setq val (let ((enable-recursive-minibuffers t))
458 (concat (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
462 (format " (default %s): " v)
464 (mapcar #'(lambda (x) (list (symbol-name x)))
466 nil t nil 'hyper-apropos-face-history
467 (and v (symbol-name v)))))
468 (list (intern-soft val)
469 current-prefix-arg)))
471 (message "Sorry, nothing to describe.")
472 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
473 (setq hyper-apropos-prev-wconfig (current-window-configuration)))
474 (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
477 (defun hyper-describe-variable (symbol &optional this-ref-buffer)
478 "Hypertext drop-in replacement for `describe-variable'.
479 See also `hyper-apropos' and `hyper-describe-function'."
480 ;; #### - perhaps a prefix arg should suppress the prompt...
481 (interactive (list (hyper-apropos-read-variable-symbol
482 (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
484 "Describe variable"))
487 (message "Sorry, nothing to describe.")
488 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
489 (setq hyper-apropos-prev-wconfig (current-window-configuration)))
490 (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
493 (defun hyper-where-is (symbol)
494 "Print message listing key sequences that invoke specified command."
495 (interactive (list (hyper-apropos-read-function-symbol "Where is function")))
497 (message "Sorry, nothing to describe.")
501 (defun hyper-describe-function (symbol &optional this-ref-buffer)
502 "Hypertext replacement for `describe-function'. Unlike `describe-function'
503 in that the symbol under the cursor is the default if it is a function.
504 See also `hyper-apropos' and `hyper-describe-variable'."
505 ;; #### - perhaps a prefix arg should suppress the prompt...
506 (interactive (list (hyper-apropos-read-function-symbol
507 (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
509 "Describe function"))
512 (message "Sorry, nothing to describe.")
513 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
514 (setq hyper-apropos-prev-wconfig (current-window-configuration)))
515 (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
518 (defun hyper-apropos-read-variable-symbol (prompt &optional predicate)
519 "Hypertext drop-in replacement for `describe-variable'.
520 See also `hyper-apropos' and `hyper-describe-function'."
521 ;; #### - perhaps a prefix arg should suppress the prompt...
522 (or predicate (setq predicate 'boundp))
524 (setq v (hyper-apropos-this-symbol)) ; symbol under point
525 (or (funcall predicate v)
526 (setq v (variable-at-point)))
527 (or (funcall predicate v)
529 (setq val (let ((enable-recursive-minibuffers t))
533 (format " (default %s): " v)
535 obarray predicate t nil 'variable-history
536 (and v (symbol-name v)))))
540 (define-obsolete-function-alias
541 'hypropos-read-variable-symbol 'hyper-apropos-read-variable-symbol)
543 (defun hyper-apropos-read-function-symbol (prompt)
544 "Read function symbol from minibuffer."
545 (let ((fn (hyper-apropos-this-symbol))
548 (setq fn (function-at-point)))
549 (setq val (let ((enable-recursive-minibuffers t))
550 (completing-read (if fn
551 (format "%s (default %s): " prompt fn)
552 (format "%s: " prompt))
553 obarray 'fboundp t nil
555 (and fn (symbol-name fn)))))
558 (defun hyper-apropos-last-help (arg)
559 "Go back to the last symbol documented in the *Hyper Help* buffer."
561 (let ((win (get-buffer-window hyper-apropos-help-buf)))
562 (or arg (setq arg (if win 1 0)))
564 ((<= (length hyper-apropos-help-history) arg)
565 ;; go back as far as we can...
566 (setcdr (nreverse hyper-apropos-help-history) nil))
568 (setq hyper-apropos-help-history
569 (nthcdr arg hyper-apropos-help-history))))
570 (if (or win (> arg 0))
571 (hyper-apropos-get-doc (car hyper-apropos-help-history) t)
572 (display-buffer hyper-apropos-help-buf))))
574 (defun hyper-apropos-insert-face (string &optional face)
575 "Insert STRING and fontify some parts with face `hyper-apropos-hyperlink'."
576 (let ((beg (point)) end)
577 (insert-face string (or face 'hyper-apropos-documentation))
580 (while (re-search-forward
581 #r"`\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\)'"
583 (let ((e (make-extent (match-beginning 1) (match-end 1))))
584 (set-extent-face e 'hyper-apropos-hyperlink)
585 (set-extent-property e 'mouse-face 'highlight)))
587 (while (re-search-forward
588 #r"M-x \([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\)"
590 (let ((e (make-extent (match-beginning 1) (match-end 1))))
591 (set-extent-face e 'hyper-apropos-hyperlink)
592 (set-extent-property e 'mouse-face 'highlight)))))
594 (defun hyper-apropos-insert-keybinding (keys string)
596 (insert " (" string " bound to \""
597 (mapconcat 'key-description
598 (sort* keys #'< :key #'length)
602 (defun hyper-apropos-insert-section-heading (alias-desc &optional desc)
603 (or desc (setq desc alias-desc
606 (setq desc (concat alias-desc
607 (if (memq (aref desc 0)
611 (aset desc 0 (upcase (aref desc 0))) ; capitalize
612 (goto-char (point-max))
613 (newline 3) (delete-blank-lines) (newline 2)
614 (hyper-apropos-insert-face desc 'hyper-apropos-section-heading))
616 (defun hyper-apropos-insert-value (string symbol val)
617 (insert-face string 'hyper-apropos-heading)
618 (insert (if (symbol-value symbol)
619 (if (or (null val) (eq val t) (integerp val))
621 (symbol-value symbol)
626 (defun hyper-apropos-follow-ref-buffer (this-ref-buffer)
627 (and (not this-ref-buffer)
628 (eq major-mode 'hyper-apropos-help-mode)
629 hyper-apropos-ref-buffer
630 (buffer-live-p hyper-apropos-ref-buffer)))
632 (defun hyper-apropos-get-alias (symbol alias-p next-symbol &optional use)
633 "Return (TERMINAL-SYMBOL . ALIAS-DESC)."
635 (while (funcall alias-p symbol)
636 (setq aliases (cons (if use (funcall use symbol) symbol) aliases))
637 (setq symbol (funcall next-symbol symbol)))
640 (concat "an alias for `"
641 (mapconcat 'symbol-name
643 "',\nwhich is an alias for `")
646 (defun hyper-apropos-get-doc (&optional symbol force type this-ref-buffer)
647 ;; #### - update this docstring
648 "Toggle display of documentation for the symbol on the current line."
649 ;; SYMBOL is the symbol to document. FORCE, if non-nil, means to
650 ;; regenerate the documentation even if it already seems to be there. And
651 ;; TYPE, if present, forces the generation of only variable documentation
652 ;; or only function documentation. Normally, if both are present, then
653 ;; both will be generated.
655 ;; TYPES TO IMPLEMENT: obsolete face
659 (setq symbol (hyper-apropos-this-symbol)))
661 (setq type '(function variable face)))
662 (if (and (eq hyper-apropos-currently-showing symbol)
663 (get-buffer hyper-apropos-help-buf)
664 (get-buffer-window hyper-apropos-help-buf)
666 ;; we're already displaying this help, so toggle its display.
667 (delete-windows-on hyper-apropos-help-buf)
668 ;; OK, we've got to refresh and display it...
669 (or (eq symbol (car hyper-apropos-help-history))
670 (setq hyper-apropos-help-history
671 (if (eq major-mode 'hyper-apropos-help-mode)
672 ;; if we're following a link in the help buffer, then
673 ;; record that in the help history.
674 (cons symbol hyper-apropos-help-history)
675 ;; otherwise clear the history because it's a new search.
678 (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
679 (set-buffer hyper-apropos-ref-buffer)
680 (setq hyper-apropos-ref-buffer (current-buffer)))
681 (let (standard-output
683 newsym symtype doc obsolete
685 global local-str global-str
687 aliases alias-desc desc)
689 (set-buffer (get-buffer-create hyper-apropos-help-buf))
690 ;;(setq standard-output (current-buffer))
691 (setq buffer-read-only nil)
693 (insert-face (format "`%s'" symbol) 'hyper-apropos-major-heading)
694 (insert (format " (buffer: %s, mode: %s)\n"
695 (buffer-name hyper-apropos-ref-buffer)
697 ;; function ----------------------------------------------------------
698 (and (memq 'function type)
702 (setq aliases (hyper-apropos-get-alias (symbol-function symbol)
706 alias-desc (cdr aliases))
707 (if (eq 'macro (car-safe newsym))
710 (setq desc "function"))
711 (setq symtype (cond ((subrp newsym) 'subr)
712 ((compiled-function-p newsym) 'bytecode)
713 ((eq (car-safe newsym) 'autoload) 'autoload)
714 ((eq (car-safe newsym) 'lambda) 'lambda))
715 desc (concat (if (commandp symbol) "interactive ")
717 '((subr . "built-in ")
718 (bytecode . "compiled Lisp ")
719 (autoload . "autoloaded Lisp ")
720 (lambda . "Lisp "))))
723 ((autoload) (format ",\n(autoloaded from \"%s\")"
725 ((bytecode) (format ",\n(loaded from \"%s\")"
726 (symbol-file symbol)))))
727 local (current-local-map)
728 global (current-global-map)
729 obsolete (get symbol 'byte-obsolete-info)
730 doc (or (condition-case nil
731 (documentation symbol)
733 "(alias for undefined function)")
734 (error "(unexpected error from `documention')"))
735 "function not documented"))
737 (set-buffer hyper-apropos-help-buf)
738 (goto-char (point-max))
739 (setq standard-output (current-buffer))
740 (hyper-apropos-insert-section-heading alias-desc desc)
743 (hyper-apropos-insert-keybinding
744 (where-is-internal symbol (list local) nil nil nil)
746 (hyper-apropos-insert-keybinding
747 (where-is-internal symbol (list global) nil nil nil)
751 (hyper-apropos-insert-face
752 (format "%s is an obsolete function; %s\n\n" symbol
753 (if (stringp (car obsolete))
755 (format "use `%s' instead." (car obsolete))))
756 'hyper-apropos-warning))
758 (insert-face "arguments: " 'hyper-apropos-heading)
759 (cond ((eq symtype 'lambda)
760 (princ (or (nth 1 newsym) "()")))
761 ((eq symtype 'bytecode)
762 (princ (or (compiled-function-arglist newsym)
764 ((and (or (eq symtype 'subr) (eq symtype 'autoload))
766 "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'"
768 (insert (substring doc
771 (setq doc (substring doc 0 (match-beginning 0))))
772 ((and (eq symtype 'subr)
774 "\[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
782 (setq doc (substring doc (match-end 0))))
783 (t (princ "[not available]")))
785 (hyper-apropos-insert-face doc)
787 (indent-rigidly beg (point) 2))))
788 ;; variable ----------------------------------------------------------
789 (and (memq 'variable type)
790 (or (boundp symbol) (default-boundp symbol))
793 (setq aliases (hyper-apropos-get-alias symbol
798 alias-desc (cdr aliases))
799 (setq symtype (or (local-variable-p newsym (current-buffer))
800 (and (local-variable-p newsym
803 desc (concat (and (get newsym 'custom-type)
805 (if (user-variable-p newsym)
808 (cond ((eq symtype t) ", buffer-local")
809 ((eq symtype 'auto-local)
810 ", local when set")))
811 local (and (boundp newsym)
812 (symbol-value newsym))
813 local-str (and (boundp newsym)
814 (prin1-to-string local))
815 global (and (eq symtype t)
816 (default-boundp newsym)
817 (default-value newsym))
818 global-str (and (eq symtype t)
819 (default-boundp newsym)
820 (prin1-to-string global))
821 obsolete (get symbol 'byte-obsolete-variable)
822 doc (or (documentation-property symbol
823 'variable-documentation)
824 "variable not documented"))
826 (set-buffer hyper-apropos-help-buf)
827 (goto-char (point-max))
828 (setq standard-output (current-buffer))
829 (hyper-apropos-insert-section-heading alias-desc desc)
830 (when (and (user-variable-p newsym)
831 (get newsym 'custom-type))
832 (let ((e (make-extent (point-at-bol) (point))))
833 (set-extent-property e 'mouse-face 'highlight)
834 (set-extent-property e 'help-echo
835 (format "Customize %s" newsym))
837 e 'hyper-apropos-custom
838 `(lambda () (customize-variable (quote ,newsym))))))
842 (hyper-apropos-insert-face
843 (format "%s is an obsolete function; %s\n\n" symbol
844 (if (stringp obsolete)
846 (format "use `%s' instead." obsolete)))
847 'hyper-apropos-warning))
848 ;; generally, the value of the variable is short and the
849 ;; documentation of the variable long, so it's desirable
850 ;; to see all of the value and the start of the
851 ;; documentation. Some variables, though, have huge and
852 ;; nearly meaningless values that force you to page
853 ;; forward just to find the doc string. That is
855 (if (and (or (null local-str) (< (length local-str) 69))
856 (or (null global-str) (< (length global-str) 69)))
857 ; 80 cols. docstrings assume this.
858 (progn (insert-face "value: " 'hyper-apropos-heading)
859 (insert (or local-str "is void"))
863 (insert-face "default value: " 'hyper-apropos-heading)
864 (insert (or global-str "is void"))))
866 (hyper-apropos-insert-face doc))
867 (hyper-apropos-insert-value "value: " 'local-str local)
871 (hyper-apropos-insert-value "default-value: "
872 'global-str global)))
874 (hyper-apropos-insert-face doc)
877 (newline 3) (delete-blank-lines) (newline 1)
878 (insert-face "value: " 'hyper-apropos-heading)
879 (if hyper-apropos-prettyprint-long-values
881 (cl-prettyprint local)
882 (error (insert local-str)))
883 (insert local-str))))
886 (newline 3) (delete-blank-lines) (newline 1)
887 (insert-face "default value: " 'hyper-apropos-heading)
888 (if hyper-apropos-prettyprint-long-values
890 (cl-prettyprint global)
891 (error (insert global-str)))
892 (insert global-str)))))
893 (indent-rigidly beg (point) 2))))
894 ;; face --------------------------------------------------------------
895 (and (memq 'face type)
899 (copy-face symbol 'hyper-apropos-temp-face 'global)
900 (mapcar #'(lambda (property)
901 (setq symtype (face-property-instance symbol
904 (set-face-property 'hyper-apropos-temp-face
907 built-in-face-specifiers)
908 (setq font (cons (face-property-instance symbol 'font nil 0 t)
909 (face-property-instance symbol 'font))
910 fore (cons (face-foreground-instance symbol nil 0 t)
911 (face-foreground-instance symbol))
912 back (cons (face-background-instance symbol nil 0 t)
913 (face-background-instance symbol))
914 undl (cons (face-underline-p symbol nil 0 t)
915 (face-underline-p symbol))
916 doc (face-doc-string symbol))
917 ;; #### - add some code here
919 (set-buffer hyper-apropos-help-buf)
920 (setq standard-output (current-buffer))
921 (hyper-apropos-insert-section-heading
923 (when (get symbol 'face-defface-spec)
924 (let* ((str " (customizable)")
925 (e (make-extent 1 (length str) str)))
926 (set-extent-property e 'mouse-face 'highlight)
927 (set-extent-property e 'help-echo
928 (format "Customize %s" symbol))
929 (set-extent-property e 'unique t)
930 (set-extent-property e 'duplicable t)
932 e 'hyper-apropos-custom
933 `(lambda () (customize-face (quote ,symbol))))
936 (insert-face "ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
937 'hyper-apropos-temp-face)
939 (insert-face " Font: " 'hyper-apropos-heading)
940 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
942 (font-instance-name (cdr font)))))
943 (insert-face " Foreground: " 'hyper-apropos-heading)
944 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
946 (color-instance-name (cdr fore)))))
947 (insert-face " Background: " 'hyper-apropos-heading)
948 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
950 (color-instance-name (cdr back)))))
951 (insert-face " Underline: " 'hyper-apropos-heading)
952 (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n")
959 (indent-rigidly beg (point) 2))))))
960 ;; not bound & property list -----------------------------------------
963 (set-buffer hyper-apropos-help-buf)
964 (hyper-apropos-insert-section-heading
965 "symbol is not currently bound\n")))
966 (if (and (setq symtype (symbol-plist symbol))
967 (or (> (length symtype) 2)
968 (not (memq 'variable-documentation symtype))))
970 (set-buffer hyper-apropos-help-buf)
971 (goto-char (point-max))
972 (setq standard-output (current-buffer))
973 (hyper-apropos-insert-section-heading "property-list:\n\n")
975 (if (memq (car symtype)
976 '(variable-documentation byte-obsolete-info))
977 (setq symtype (cdr symtype))
978 (insert-face (concat " " (symbol-name (car symtype))
980 'hyper-apropos-heading)
981 (setq symtype (cdr symtype))
983 (insert (prin1-to-string (car symtype)) "\n"))
984 (setq symtype (cdr symtype)))))))
986 (set-buffer hyper-apropos-help-buf)
987 (goto-char (point-min))
988 ;; pop up window and shrink it if it's wasting space
989 (if hyper-apropos-shrink-window
990 (shrink-window-if-larger-than-buffer
991 (display-buffer (current-buffer)))
992 (display-buffer (current-buffer)))
993 (hyper-apropos-help-mode))
994 (setq hyper-apropos-currently-showing symbol)))
996 (define-obsolete-function-alias
997 'hypropos-get-doc 'hyper-apropos-get-doc)
999 ; -----------------------------------------------------------------------------
1001 (defun hyper-apropos-help-mode ()
1002 "Major mode for hypertext XEmacs help. In this mode, you can quickly
1003 follow links between back and forth between the documentation strings for
1004 different variables and functions. Common commands:
1006 \\{hyper-apropos-help-map}"
1007 (setq buffer-read-only t
1008 major-mode 'hyper-apropos-help-mode
1009 mode-name "Hyper-Help")
1010 (set-syntax-table emacs-lisp-mode-syntax-table)
1011 (use-local-map hyper-apropos-help-map))
1013 ;; ---------------------------------------------------------------------- ;;
1015 (defun hyper-apropos-scroll-up ()
1016 "Scroll up the \"*Hyper Help*\" buffer if it's visible.
1017 Otherwise, scroll the selected window up."
1019 (let ((win (get-buffer-window hyper-apropos-help-buf))
1020 (owin (selected-window)))
1026 (error (goto-char (point-max))))
1027 (select-window owin))
1030 (defun hyper-apropos-scroll-down ()
1031 "Scroll down the \"*Hyper Help*\" buffer if it's visible.
1032 Otherwise, scroll the selected window down."
1034 (let ((win (get-buffer-window hyper-apropos-help-buf))
1035 (owin (selected-window)))
1041 (error (goto-char (point-max))))
1042 (select-window owin))
1043 (scroll-down nil))))
1045 ;; ---------------------------------------------------------------------- ;;
1047 (defun hyper-apropos-mouse-get-doc (event)
1048 "Get the documentation for the symbol the mouse is on."
1050 (mouse-set-point event)
1051 (let ((e (extent-at (point) nil 'hyper-apropos-custom)))
1053 (funcall (extent-property e 'hyper-apropos-custom))
1055 (let ((symbol (hyper-apropos-this-symbol)))
1057 (hyper-apropos-get-doc symbol)
1058 (error "Click on a symbol")))))))
1060 ;; ---------------------------------------------------------------------- ;;
1062 (defun hyper-apropos-add-keyword (pattern)
1063 "Use additional keyword to narrow regexp match.
1064 Deletes lines which don't match PATTERN."
1065 (interactive "sAdditional Keyword: ")
1067 (goto-char (point-min))
1068 (let (buffer-read-only)
1069 (keep-lines (concat pattern "\\|" hyper-apropos-junk-regexp))
1072 (defun hyper-apropos-eliminate-keyword (pattern)
1073 "Use additional keyword to eliminate uninteresting matches.
1074 Deletes lines which match PATTERN."
1075 (interactive "sKeyword to eliminate: ")
1077 (goto-char (point-min))
1078 (let (buffer-read-only)
1079 (flush-lines pattern))
1082 ;; ---------------------------------------------------------------------- ;;
1084 (defun hyper-apropos-this-symbol ()
1086 (cond ((eq major-mode 'hyper-apropos-mode)
1088 (if (looking-at hyper-apropos-junk-regexp)
1091 (read (point-marker))))
1092 ;; What's this? This ends up in the same symbol already described.
1094 ;; (eq major-mode 'hyper-apropos-help-mode)
1095 ;; (> (point) (point-min)))
1097 ;; (goto-char (point-min))
1098 ;; (hyper-apropos-this-symbol)))
1101 (skip-syntax-backward "w_")
1102 ;; !@(*$^%%# stupid backquote implementation!!!
1103 (skip-chars-forward "`")
1106 (skip-syntax-forward "w_")
1107 (skip-chars-backward ".':") ; : for Local Variables
1109 (and (not (eq st en))
1110 (intern-soft (buffer-substring st en))))))))
1112 (defun hyper-apropos-where-is (symbol)
1113 "Find keybinding for symbol on current line."
1114 (interactive (list (hyper-apropos-this-symbol)))
1117 (defun hyper-apropos-invoke-fn (fn)
1118 "Interactively invoke the function on the current line."
1119 (interactive (list (hyper-apropos-this-symbol)))
1120 (cond ((not (fboundp fn))
1121 (error "%S is not a function" fn))
1122 (t (call-interactively fn))))
1125 (defun hyper-set-variable (var val &optional this-ref-buffer)
1127 (let ((var (hyper-apropos-read-variable-symbol
1128 (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
1129 "In ref buffer, set user option"
1132 (list var (hyper-apropos-read-variable-value var) current-prefix-arg)))
1133 (hyper-apropos-set-variable var val this-ref-buffer))
1136 (defun hyper-apropos-set-variable (var val &optional this-ref-buffer)
1137 "Interactively set the variable on the current line."
1139 (let ((var (hyper-apropos-this-symbol)))
1140 (or (and var (boundp var))
1142 (list var (hyper-apropos-read-variable-value var))))
1146 (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
1148 (set-buffer hyper-apropos-ref-buffer)
1151 (hyper-apropos-get-doc var t '(variable) this-ref-buffer))))
1153 (define-obsolete-function-alias
1154 'hypropos-set-variable 'hyper-apropos-set-variable)
1156 (defun hyper-apropos-read-variable-value (var &optional this-ref-buffer)
1159 (let ((prop (get var 'variable-interactive))
1162 (hyper-apropos-get-doc var t '(variable) current-prefix-arg)
1164 (call-interactively (list 'lambda '(arg)
1165 (list 'interactive prop)
1167 (setq val (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
1169 (set-buffer hyper-apropos-ref-buffer)
1172 str (prin1-to-string val))
1174 (format "Set %s `%s' to value (evaluated): "
1175 (if (user-variable-p var) "user option" "Variable")
1180 (format (if (or (consp val)
1182 (not (memq val '(t nil)))))
1187 (defun hyper-apropos-customize-variable ()
1189 (let ((var (hyper-apropos-this-symbol)))
1191 (or (and var (boundp var))
1193 (customize-variable var))))
1195 ;; ---------------------------------------------------------------------- ;;
1197 (autoload 'find-tag-other-window "etags" nil t)
1199 (defun hyper-apropos-find-tag (&optional tag-name)
1200 "Find the tag for the symbol on the current line in other window. In
1201 order for this to work properly, the variable `tag-table-alist' or
1202 `tags-file-name' must be set so that a TAGS file with tags for the emacs
1203 source is found for the \"*Hyper Apropos*\" buffer."
1205 ;; there ought to be a default tags file for this...
1206 (or tag-name (setq tag-name (symbol-name (hyper-apropos-this-symbol))))
1207 (find-tag-other-window (list tag-name)))
1209 ;; ---------------------------------------------------------------------- ;;
1211 (defun hyper-apropos-find-function (fn)
1212 "Find the function for the symbol on the current line in other
1213 window. (See also `find-function'.)"
1215 (let ((fn (hyper-apropos-this-symbol)))
1220 (declare-fboundp (find-function-other-window fn))))
1222 ;; ---------------------------------------------------------------------- ;;
1223 (autoload 'disassemble "disass" nil t)
1225 (defun hyper-apropos-disassemble (sym)
1226 "Disassemble FUN if it is byte-coded. If it's a lambda, prettyprint it."
1227 (interactive (list (hyper-apropos-this-symbol)))
1228 (let ((fun sym) (trail nil) macrop)
1229 (while (and (symbolp fun) (not (memq fun trail)))
1230 (setq trail (cons fun trail)
1231 fun (symbol-function fun)))
1233 (error "Loop detected in function binding of `%s'" fun))
1234 (setq macrop (and (consp fun)
1235 (eq 'macro (car fun))))
1236 (cond ((compiled-function-p (if macrop (cdr fun) fun))
1238 (set-buffer "*Disassemble*")
1239 (goto-char (point-min))
1241 (insert (format " for function `%S'" sym))
1244 (with-current-buffer "*Disassemble*"
1245 (cl-prettyprint (if macrop
1246 (cons 'defmacro (cons sym (cdr (cdr fun))))
1247 (cons 'defun (cons sym (cdr fun))))))
1248 (set-buffer "*Disassemble*")
1250 ((or (vectorp fun) (stringp fun))
1251 ;; #### - do something fancy here
1252 (with-output-to-temp-buffer "*Disassemble*"
1253 (princ (format "%s is a keyboard macro:\n\n\t" sym))
1256 (error "Sorry, cannot disassemble `%s'" sym)))))
1258 ;; ---------------------------------------------------------------------- ;;
1260 (defun hyper-apropos-quit ()
1262 "Quit Hyper Apropos and restore original window config."
1263 (let ((buf (get-buffer hyper-apropos-apropos-buf)))
1264 (and buf (bury-buffer buf)))
1265 (set-window-configuration hyper-apropos-prev-wconfig))
1267 ;; ---------------------------------------------------------------------- ;;
1270 (defun hyper-apropos-popup-menu (event)
1272 (mouse-set-point event)
1273 (let* ((sym (hyper-apropos-this-symbol))
1274 (notjunk (not (null sym)))
1275 (command-p (if (commandp sym) t))
1276 (variable-p (and sym (boundp sym)))
1277 (customizable-p (and variable-p
1278 (get sym 'custom-type)
1280 (function-p (fboundp sym))
1281 (apropos-p (eq 'hyper-apropos-mode
1282 (save-excursion (set-buffer (event-buffer event))
1284 (name (if sym (symbol-name sym) ""))
1288 (list (concat "Hyper-Help: " name)
1289 (vector "Display documentation" 'hyper-apropos-get-doc notjunk)
1290 (vector "Set variable" 'hyper-apropos-set-variable variable-p)
1291 (vector "Customize variable" 'hyper-apropos-customize-variable
1293 (vector "Show keys for" 'hyper-apropos-where-is command-p)
1294 (vector "Invoke command" 'hyper-apropos-invoke-fn command-p)
1295 (vector "Find function" 'hyper-apropos-find-function function-p)
1296 (vector "Find tag" 'hyper-apropos-find-tag notjunk)
1298 ["Add keyword..." hyper-apropos-add-keyword t])
1300 ["Eliminate keyword..." hyper-apropos-eliminate-keyword t])
1302 ["Programmers' Apropos" hyper-apropos-toggle-programming-flag
1303 :style toggle :selected hyper-apropos-programming-apropos]
1304 ["Programmers' Help" hyper-apropos-toggle-programming-flag
1305 :style toggle :selected hyper-apropos-programming-apropos])
1306 (and hyper-apropos-programming-apropos
1307 (vector "Disassemble function"
1308 'hyper-apropos-disassemble
1310 ["Help" describe-mode t]
1311 ["Quit" hyper-apropos-quit t]
1313 (popup-menu hyper-apropos-menu)))
1315 (define-obsolete-function-alias
1316 'hypropos-popup-menu 'hyper-apropos-popup-menu)
1318 (provide 'hyper-apropos)
1320 ;; end of hyper-apropos.el