Mercurial > hg > xemacs-beta
annotate lisp/hyper-apropos.el @ 5173:bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
2010-03-29 Aidan Kehoe <kehoea@parhasard.net>
* hyper-apropos.el (hyper-apropos-get-doc):
Use help.el's #'function-arglist, #'function-documentation,
#'symbol-file in this function, instead of rolling our own.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Mon, 29 Mar 2010 18:49:33 +0100 |
parents | fee33ab25966 |
children | fa5d6416887f |
rev | line source |
---|---|
428 | 1 ;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface. |
2 | |
502 | 3 ;; Copyright (C) 1997 Free Software Foundation, Inc. |
428 | 4 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp. |
5 ;; Copyright (C) 1995 Sun Microsystems. | |
1275 | 6 ;; Copyright (C) 1996, 2003 Ben Wing. |
428 | 7 |
502 | 8 ;; Author: Jonathan Stigelman <stig@xemacs.org> |
9 ;; Maintainer: XEmacs Development Team | |
428 | 10 ;; Keywords: lisp, tools, help, docs, matching |
11 | |
12 ;; This file is part of XEmacs. | |
13 | |
14 ;; XEmacs is free software; you can redistribute it and/or modify | |
15 ;; it under the terms of the GNU General Public License as published by | |
16 ;; the Free Software Foundation; either version 2 of the License, or | |
17 ;; (at your option) any later version. | |
18 ;; | |
19 ;; XEmacs is distributed in the hope that it will be useful, | |
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
22 ;; GNU General Public License for more details. | |
23 ;; | |
24 ;; You should have received a copy of the GNU General Public License | |
25 ;; along with XEmacs; if not, write to the Free Software | |
26 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | |
27 | |
28 ;;; Synched up with: Not in FSF. | |
29 | |
30 ;;; Commentary: | |
31 | |
32 ;; based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com> | |
33 ;; | |
34 ;; Rather than run apropos and print all the documentation at once, | |
35 ;; I find it easier to view a "table of contents" first, then | |
36 ;; get the details for symbols as you need them. | |
37 ;; | |
38 ;; This version of apropos prints two lists of symbols matching the | |
39 ;; given regexp: functions/macros and variables/constants. | |
40 ;; | |
41 ;; The user can then do the following: | |
42 ;; | |
43 ;; - add an additional regexp to narrow the search | |
44 ;; - display documentation for the current symbol | |
45 ;; - find the tag for the current symbol | |
46 ;; - show any keybindings if the current symbol is a command | |
47 ;; - invoke functions | |
48 ;; - set variables | |
49 ;; | |
50 ;; An additional feature is the ability to search the current tags | |
51 ;; table, allowing you to interrogate functions not yet loaded (this | |
52 ;; isn't available with the standard package). | |
53 ;; | |
54 ;; Mouse bindings and menus are provided for XEmacs. | |
55 ;; | |
56 ;; additions by Ben Wing <ben@xemacs.org> July 1995: | |
57 ;; added support for function aliases, made programmer's apropos be the | |
58 ;; default, various other hacking. | |
59 ;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de> | |
60 ;; Some changes for XEmacs 20.3 by hniksic | |
61 | |
440 | 62 ;; #### The maintainer is supposed to be stig, but I haven't seen him |
428 | 63 ;; around for ages. The real maintainer for the moment is Hrvoje |
64 ;; Niksic <hniksic@xemacs.org>. | |
65 | |
66 ;;; Code: | |
67 | |
68 (defgroup hyper-apropos nil | |
69 "Hypertext emacs lisp documentation interface." | |
70 :group 'docs | |
71 :group 'lisp | |
72 :group 'tools | |
73 :group 'help | |
74 :group 'matching) | |
75 | |
76 (defcustom hyper-apropos-show-brief-docs t | |
77 "*If non-nil, display some documentation in the \"*Hyper Apropos*\" buffer. | |
78 Setting this to nil will speed up searches." | |
79 :type 'boolean | |
80 :group 'hyper-apropos) | |
81 (define-obsolete-variable-alias | |
82 'hypropos-show-brief-docs 'hyper-apropos-show-brief-docs) | |
502 | 83 |
84 ;; I changed the following to true because it's obviously more useful | |
85 ;; that way, and is a very good example of following the principle of | |
86 ;; least surprise. --ben | |
428 | 87 |
88 (defcustom hyper-apropos-programming-apropos t | |
89 "*If non-nil, list all the functions and variables. | |
90 This will cause more output to be generated, and take a longer time. | |
502 | 91 Otherwise, only the interactive functions and user variables will be listed. |
428 | 92 |
502 | 93 If you're thinking of setting it to nil, consider that you can get the |
94 equivalent just by using the command \\[command-hyper-apropos]. (And if you do set it to nil, | |
95 you can get the full output by using \\[universal-argument] \\[hyper-apropos].)" | |
428 | 96 :type 'boolean |
97 :group 'hyper-apropos) | |
98 (define-obsolete-variable-alias | |
99 'hypropos-programming-apropos 'hyper-apropos-programming-apropos) | |
100 | |
101 (defcustom hyper-apropos-shrink-window nil | |
102 "*If non-nil, shrink *Hyper Help* buffer if possible." | |
103 :type 'boolean | |
104 :group 'hyper-apropos) | |
105 (define-obsolete-variable-alias | |
106 'hypropos-shrink-window 'hyper-apropos-shrink-window) | |
107 | |
108 (defcustom hyper-apropos-prettyprint-long-values t | |
109 "*If non-nil, then try to beautify the printing of very long values." | |
110 :type 'boolean | |
111 :group 'hyper-apropos) | |
112 (define-obsolete-variable-alias | |
113 'hypropos-prettyprint-long-values 'hyper-apropos-prettyprint-long-values) | |
114 | |
115 (defgroup hyper-apropos-faces nil | |
116 "Faces defined by hyper-apropos." | |
117 :prefix "hyper-apropos-" | |
118 :group 'faces) | |
119 | |
120 (defface hyper-apropos-documentation | |
121 '((((class color) (background light)) | |
122 (:foreground "darkred")) | |
123 (((class color) (background dark)) | |
124 (:foreground "gray90"))) | |
125 "Hyper-apropos documentation." | |
126 :group 'hyper-apropos-faces) | |
127 | |
128 (defface hyper-apropos-hyperlink | |
129 '((((class color) (background light)) | |
130 (:foreground "blue4")) | |
131 (((class color) (background dark)) | |
132 (:foreground "lightseagreen")) | |
133 (t | |
134 (:bold t))) | |
135 "Hyper-apropos hyperlinks." | |
136 :group 'hyper-apropos-faces) | |
137 | |
138 (defface hyper-apropos-major-heading '((t (:bold t))) | |
139 "Hyper-apropos major heading." | |
140 :group 'hyper-apropos-faces) | |
141 | |
142 (defface hyper-apropos-section-heading '((t (:bold t :italic t))) | |
143 "Hyper-apropos section heading." | |
144 :group 'hyper-apropos-faces) | |
145 | |
146 (defface hyper-apropos-heading '((t (:bold t))) | |
147 "Hyper-apropos heading." | |
148 :group 'hyper-apropos-faces) | |
149 | |
150 (defface hyper-apropos-warning '((t (:bold t :foreground "red"))) | |
151 "Hyper-apropos warning." | |
152 :group 'hyper-apropos-faces) | |
153 | |
154 ;;; Internal variables below this point | |
155 | |
156 (defvar hyper-apropos-ref-buffer) | |
157 (defvar hyper-apropos-prev-wconfig) | |
158 | |
159 (defvar hyper-apropos-help-map | |
160 (let ((map (make-sparse-keymap))) | |
161 (suppress-keymap map) | |
162 (set-keymap-name map 'hyper-apropos-help-map) | |
163 ;; movement | |
164 (define-key map " " 'scroll-up) | |
165 (define-key map "b" 'scroll-down) | |
166 (define-key map [delete] 'scroll-down) | |
167 (define-key map [backspace] 'scroll-down) | |
168 (define-key map "/" 'isearch-forward) | |
169 (define-key map "?" 'isearch-backward) | |
170 ;; follow links | |
171 (define-key map [return] 'hyper-apropos-get-doc) | |
172 (define-key map "s" 'hyper-apropos-set-variable) | |
173 (define-key map "t" 'hyper-apropos-find-tag) | |
174 (define-key map "l" 'hyper-apropos-last-help) | |
175 (define-key map "c" 'hyper-apropos-customize-variable) | |
176 (define-key map "f" 'hyper-apropos-find-function) | |
718 | 177 (define-key map "v" 'hyper-apropos-find-variable) |
428 | 178 (define-key map [button2] 'hyper-apropos-mouse-get-doc) |
179 (define-key map [button3] 'hyper-apropos-popup-menu) | |
180 ;; for the totally hardcore... | |
181 (define-key map "D" 'hyper-apropos-disassemble) | |
182 ;; administrativa | |
183 (define-key map "a" 'hyper-apropos) | |
184 (define-key map "n" 'hyper-apropos) | |
185 (define-key map "q" 'hyper-apropos-quit) | |
186 map) | |
187 "Keybindings for the *Hyper Help* buffer and the *Hyper Apropos* buffer") | |
188 (define-obsolete-variable-alias | |
189 'hypropos-help-map 'hyper-apropos-help-map) | |
190 | |
191 (defvar hyper-apropos-map | |
192 (let ((map (make-sparse-keymap))) | |
193 (set-keymap-name map 'hyper-apropos-map) | |
194 (set-keymap-parents map (list hyper-apropos-help-map)) | |
195 ;; slightly different scrolling... | |
196 (define-key map " " 'hyper-apropos-scroll-up) | |
197 (define-key map "b" 'hyper-apropos-scroll-down) | |
198 (define-key map [delete] 'hyper-apropos-scroll-down) | |
199 (define-key map [backspace] 'hyper-apropos-scroll-down) | |
200 ;; act on the current line... | |
201 (define-key map "w" 'hyper-apropos-where-is) | |
202 (define-key map "i" 'hyper-apropos-invoke-fn) | |
203 ;; this is already defined in the parent-keymap above, isn't it? | |
204 ;; (define-key map "s" 'hyper-apropos-set-variable) | |
205 ;; more administrativa... | |
206 (define-key map "P" 'hyper-apropos-toggle-programming-flag) | |
207 (define-key map "k" 'hyper-apropos-add-keyword) | |
208 (define-key map "e" 'hyper-apropos-eliminate-keyword) | |
209 map) | |
210 "Keybindings for the *Hyper Apropos* buffer. | |
3061 | 211 This map inherits from `hyper-apropos-help-map'.") |
428 | 212 (define-obsolete-variable-alias |
213 'hypropos-map 'hyper-apropos-map) | |
214 | |
215 ;;(defvar hyper-apropos-mousable-keymap | |
216 ;; (let ((map (make-sparse-keymap))) | |
217 ;; (define-key map [button2] 'hyper-apropos-mouse-get-doc) | |
218 ;; map)) | |
219 | |
220 (defvar hyper-apropos-mode-hook nil | |
221 "*User function run after hyper-apropos mode initialization. Usage: | |
222 \(add-hook 'hyper-apropos-mode-hook #'(lambda () ... your init forms ...)).") | |
223 | |
224 ;; ---------------------------------------------------------------------- ;; | |
225 | |
226 (defconst hyper-apropos-junk-regexp | |
227 "^Apropos\\|^Functions\\|^Variables\\|^$") | |
228 | |
229 (defvar hyper-apropos-currently-showing nil) ; symbol documented in | |
230 ; help buffer now | |
231 (defvar hyper-apropos-help-history nil) ; chain of symbols followed as links in | |
232 ; help buffer | |
233 (defvar hyper-apropos-face-history nil) | |
234 ;;;(defvar hyper-apropos-variable-history nil) | |
235 ;;;(defvar hyper-apropos-function-history nil) | |
236 (defvar hyper-apropos-regexp-history nil) | |
237 (defvar hyper-apropos-last-regexp nil) ; regex used for last apropos | |
238 (defconst hyper-apropos-apropos-buf "*Hyper Apropos*") | |
239 (defconst hyper-apropos-help-buf "*Hyper Help*") | |
240 | |
241 ;;;###autoload | |
502 | 242 (defun command-hyper-apropos (regexp) |
243 "Display lists of commands and user options matching REGEXP | |
244 in buffer \"*Hyper Apropos*\". See `hyper-apropos-mode' for a | |
245 description of the available commands in a Hyper-Apropos buffer." | |
246 (interactive (list (read-from-minibuffer | |
247 "List symbols matching regexp: " | |
248 nil nil nil 'hyper-apropos-regexp-history))) | |
249 (let ((hyper-apropos-programming-apropos nil)) | |
250 (hyper-apropos regexp nil))) | |
251 | |
252 ;;;###autoload | |
428 | 253 (defun hyper-apropos (regexp toggle-apropos) |
254 "Display lists of functions and variables matching REGEXP | |
255 in buffer \"*Hyper Apropos*\". If optional prefix arg is given, then the | |
256 value of `hyper-apropos-programming-apropos' is toggled for this search. | |
502 | 257 See `hyper-apropos-mode' for a description of the available commands in |
258 a Hyper-Apropos buffer." | |
259 (interactive (list (read-from-minibuffer | |
260 "List symbols matching regexp: " | |
261 nil nil nil 'hyper-apropos-regexp-history) | |
428 | 262 current-prefix-arg)) |
263 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) | |
264 (setq hyper-apropos-prev-wconfig (current-window-configuration))) | |
265 (if (string= "" regexp) | |
266 (if (get-buffer hyper-apropos-apropos-buf) | |
434 | 267 (progn |
268 (setq regexp hyper-apropos-last-regexp) | |
269 (if toggle-apropos | |
270 (hyper-apropos-toggle-programming-flag) | |
271 (message "Using last search results"))) | |
428 | 272 (error "Be more specific...")) |
273 (set-buffer (get-buffer-create hyper-apropos-apropos-buf)) | |
274 (setq buffer-read-only nil) | |
275 (erase-buffer) | |
276 (if toggle-apropos | |
434 | 277 (if (local-variable-p 'hyper-apropos-programming-apropos |
278 (current-buffer)) | |
279 (setq hyper-apropos-programming-apropos | |
280 (not hyper-apropos-programming-apropos)) | |
281 (set (make-local-variable 'hyper-apropos-programming-apropos) | |
282 (not (default-value 'hyper-apropos-programming-apropos))))) | |
428 | 283 (let ((flist (apropos-internal regexp |
284 (if hyper-apropos-programming-apropos | |
285 #'fboundp | |
286 #'commandp))) | |
287 (vlist (apropos-internal regexp | |
288 (if hyper-apropos-programming-apropos | |
289 #'boundp | |
290 #'user-variable-p)))) | |
291 (insert-face (format "Apropos search for: %S\n\n" regexp) | |
292 'hyper-apropos-major-heading) | |
293 (insert-face "* = command (M-x) or user-variable.\n" | |
294 'hyper-apropos-documentation) | |
295 (insert-face "\ | |
296 a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n" | |
297 'hyper-apropos-documentation) | |
298 (insert-face "Functions and Macros:\n\n" 'hyper-apropos-major-heading) | |
1275 | 299 (hyper-apropos-grok-functions flist nil) |
300 (insert-face "\n\nObsolete Functions and Macros:\n\n" 'hyper-apropos-major-heading) | |
301 (hyper-apropos-grok-functions flist t) | |
428 | 302 (insert-face "\n\nVariables and Constants:\n\n" |
303 'hyper-apropos-major-heading) | |
1275 | 304 (hyper-apropos-grok-variables vlist nil) |
305 (insert-face "\n\nObsolete Variables and Constants:\n\n" | |
306 'hyper-apropos-major-heading) | |
307 (hyper-apropos-grok-variables vlist t) | |
428 | 308 (goto-char (point-min)))) |
309 (switch-to-buffer hyper-apropos-apropos-buf) | |
310 (hyper-apropos-mode regexp)) | |
311 | |
312 (defun hyper-apropos-toggle-programming-flag () | |
313 (interactive) | |
314 (with-current-buffer hyper-apropos-apropos-buf | |
315 (set (make-local-variable 'hyper-apropos-programming-apropos) | |
316 (not hyper-apropos-programming-apropos))) | |
317 (message "Re-running apropos...") | |
318 (hyper-apropos hyper-apropos-last-regexp nil)) | |
319 | |
1275 | 320 (defun hyper-apropos-grok-functions (fns obsolete-p) |
321 (loop for fn in fns | |
322 if (eq (function-obsolete-p fn) obsolete-p) do | |
323 (let* ((bind (symbol-function fn)) | |
324 (type (cond ((subrp bind) ?i) | |
428 | 325 ((compiled-function-p bind) ?b) |
326 ((consp bind) (or (cdr | |
327 (assq (car bind) '((autoload . ?a) | |
328 (lambda . ?l) | |
329 (macro . ?m)))) | |
330 ??)) | |
1275 | 331 (t ?\ )))) |
428 | 332 (insert type (if (commandp fn) "* " " ")) |
333 (let ((e (insert-face (format "%S" fn) 'hyper-apropos-hyperlink))) | |
334 (set-extent-property e 'mouse-face 'highlight)) | |
335 (insert-char ?\ (let ((l (- 30 (length (format "%S" fn))))) | |
336 (if (natnump l) l 0))) | |
337 (and hyper-apropos-show-brief-docs | |
1275 | 338 (let ((doc |
339 (if (and obsolete-p | |
340 (symbolp fn) | |
341 (symbolp (symbol-function fn))) | |
342 (function-obsoleteness-doc fn) | |
343 ;; A symbol's function slot can point to an unbound symbol. | |
344 ;; In that case, `documentation' will fail. | |
2275 | 345 (condition-case nil |
346 (documentation fn) | |
347 (void-function "(alias for undefined function)") | |
348 (error "(unexpected error from `documention')"))))) | |
1275 | 349 (if (and |
350 doc | |
351 (string-match | |
352 "\\`([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)" | |
353 doc)) | |
354 (setq doc (substring doc (match-end 0) | |
355 (string-match "\n" doc)))) | |
356 ;; Skip errant newlines at beginning of doc | |
357 (if (and doc | |
358 (string-match "\\`\n+" doc)) | |
359 (setq doc (substring doc (match-end 0)))) | |
360 (insert-face (if doc | |
361 (concat " - " | |
362 (substring doc 0 | |
363 (string-match "\n" doc))) | |
364 " - Not documented.") | |
365 'hyper-apropos-documentation))) | |
428 | 366 (insert ?\n)))) |
367 | |
1275 | 368 (defun hyper-apropos-grok-variables (vars obsolete-p) |
369 (loop for var in vars | |
370 if (eq (variable-obsolete-p var) obsolete-p) do | |
371 (let ((userp (user-variable-p var))) | |
428 | 372 (insert (if userp " * " " ")) |
373 (let ((e (insert-face (format "%S" var) 'hyper-apropos-hyperlink))) | |
374 (set-extent-property e 'mouse-face 'highlight)) | |
375 (insert-char ?\ (let ((l (- 30 (length (format "%S" var))))) | |
376 (if (natnump l) l 0))) | |
377 (and hyper-apropos-show-brief-docs | |
1275 | 378 (let ((doc |
379 (if (and obsolete-p (variable-alias var)) | |
380 (variable-obsoleteness-doc var) | |
381 (documentation-property var 'variable-documentation)))) | |
382 ;; Skip errant newlines at beginning of doc | |
383 (if (and doc | |
384 (string-match "\\`\n+" doc)) | |
385 (setq doc (substring doc (match-end 0)))) | |
386 (insert-face (if doc | |
387 (concat " - " (substring | |
388 doc (if userp 1 0) | |
389 (string-match "\n" doc))) | |
390 " - Not documented.") | |
391 'hyper-apropos-documentation))) | |
428 | 392 (insert ?\n)))) |
393 | |
394 ;; ---------------------------------------------------------------------- ;; | |
395 | |
396 (defun hyper-apropos-mode (regexp) | |
397 "Improved apropos mode for displaying Emacs documentation. Function and | |
398 variable names are displayed in the buffer \"*Hyper Apropos*\". | |
399 | |
400 Functions are preceded by a single character to indicates their types: | |
401 a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro. | |
402 Interactive functions are also preceded by an asterisk. | |
403 Variables are preceded by an asterisk if they are user variables. | |
404 | |
405 General Commands: | |
406 | |
407 SPC - scroll documentation or apropos window forward | |
408 b - scroll documentation or apropos window backward | |
409 k - eliminate all hits that don't contain keyword | |
410 n - new search | |
411 / - isearch-forward | |
412 q - quit and restore previous window configuration | |
413 | |
414 Operations for Symbol on Current Line: | |
415 | |
416 RET - toggle display of symbol's documentation | |
417 (also on button2 in xemacs) | |
418 w - show the keybinding if symbol is a command | |
419 i - invoke function on current line | |
420 s - set value of variable on current line | |
421 t - display the C or lisp source (find-tag)" | |
422 (delete-other-windows) | |
423 (setq mode-name "Hyper-Apropos" | |
424 major-mode 'hyper-apropos-mode | |
425 buffer-read-only t | |
426 truncate-lines t | |
427 hyper-apropos-last-regexp regexp | |
428 modeline-buffer-identification | |
429 (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ") | |
430 (cons modeline-buffer-id-right-extent (concat "\"" regexp "\"")))) | |
431 (use-local-map hyper-apropos-map) | |
432 (run-hooks 'hyper-apropos-mode-hook)) | |
433 | |
434 ;; ---------------------------------------------------------------------- ;; | |
435 | |
436 ;; similar to `describe-key-briefly', copied from help.el by CW | |
437 | |
438 ;;;###autoload | |
439 (defun hyper-describe-key (key) | |
440 (interactive "kDescribe key: ") | |
441 (hyper-describe-key-briefly key t)) | |
442 | |
443 ;;;###autoload | |
444 (defun hyper-describe-key-briefly (key &optional show) | |
445 (interactive "kDescribe key briefly: \nP") | |
446 (let (menup defn interm final msg) | |
447 (setq defn (key-or-menu-binding key 'menup)) | |
448 (if (or (null defn) (integerp defn)) | |
449 (or (numberp show) (message "%s is undefined" (key-description key))) | |
450 (cond ((stringp defn) | |
451 (setq interm defn | |
452 final (key-binding defn))) | |
453 ((vectorp defn) | |
454 (setq interm (append defn nil)) | |
455 (while (and interm | |
456 (member (key-binding (vector (car interm))) | |
457 '(universal-argument digit-argument))) | |
458 (setq interm (cdr interm))) | |
459 (while (and interm | |
460 (not (setq final (key-binding (vconcat interm))))) | |
461 (setq interm (butlast interm))) | |
462 (if final | |
463 (setq interm (vconcat interm)) | |
464 (setq interm defn | |
465 final (key-binding defn))))) | |
466 (setq msg (format | |
467 "%s runs %s%s%s" | |
468 ;; This used to say 'This menu item' but it could also | |
469 ;; be a scrollbar event. We can't distinguish at the | |
470 ;; moment. | |
471 (if menup "This item" (key-description key)) | |
472 ;;(if (symbolp defn) defn (key-description defn)) | |
473 (if (symbolp defn) defn (prin1-to-string defn)) | |
474 (if final (concat ", " (key-description interm) " runs ") "") | |
475 (if final | |
476 (if (symbolp final) final (prin1-to-string final)) | |
477 ""))) | |
478 (if (numberp show) | |
479 (or (not (symbolp defn)) | |
480 (memq (symbol-function defn) | |
481 '(zkey-init-kbd-macro zkey-init-kbd-fn)) | |
482 (progn (princ msg) (princ "\n"))) | |
483 (message "%s" msg) | |
484 (if final (setq defn final)) | |
485 (if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn)))) | |
486 defn | |
487 show) | |
438 | 488 (hyper-apropos-get-doc defn t)) |
489 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) | |
490 (setq hyper-apropos-prev-wconfig (current-window-configuration))))))) | |
428 | 491 |
492 ;;;###autoload | |
493 (defun hyper-describe-face (symbol &optional this-ref-buffer) | |
494 "Describe face.. | |
495 See also `hyper-apropos' and `hyper-describe-function'." | |
496 ;; #### - perhaps a prefix arg should suppress the prompt... | |
497 (interactive | |
498 (let (v val) | |
499 (setq v (hyper-apropos-this-symbol)) ; symbol under point | |
500 (or (find-face v) | |
501 (setq v (variable-at-point))) | |
502 (setq val (let ((enable-recursive-minibuffers t)) | |
503 (completing-read | |
504 (concat (if (hyper-apropos-follow-ref-buffer current-prefix-arg) | |
505 "Follow face" | |
506 "Describe face") | |
507 (if v | |
508 (format " (default %s): " v) | |
509 ": ")) | |
510 (mapcar #'(lambda (x) (list (symbol-name x))) | |
511 (face-list)) | |
438 | 512 nil t nil 'hyper-apropos-face-history |
513 (and v (symbol-name v))))) | |
514 (list (intern-soft val) | |
428 | 515 current-prefix-arg))) |
516 (if (null symbol) | |
517 (message "Sorry, nothing to describe.") | |
518 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) | |
519 (setq hyper-apropos-prev-wconfig (current-window-configuration))) | |
520 (hyper-apropos-get-doc symbol t nil this-ref-buffer))) | |
521 | |
522 ;;;###autoload | |
523 (defun hyper-describe-variable (symbol &optional this-ref-buffer) | |
524 "Hypertext drop-in replacement for `describe-variable'. | |
525 See also `hyper-apropos' and `hyper-describe-function'." | |
526 ;; #### - perhaps a prefix arg should suppress the prompt... | |
527 (interactive (list (hyper-apropos-read-variable-symbol | |
528 (if (hyper-apropos-follow-ref-buffer current-prefix-arg) | |
529 "Follow variable" | |
530 "Describe variable")) | |
531 current-prefix-arg)) | |
532 (if (null symbol) | |
533 (message "Sorry, nothing to describe.") | |
534 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) | |
535 (setq hyper-apropos-prev-wconfig (current-window-configuration))) | |
536 (hyper-apropos-get-doc symbol t nil this-ref-buffer))) | |
537 | |
538 ;;;###autoload | |
539 (defun hyper-where-is (symbol) | |
540 "Print message listing key sequences that invoke specified command." | |
541 (interactive (list (hyper-apropos-read-function-symbol "Where is function"))) | |
542 (if (null symbol) | |
543 (message "Sorry, nothing to describe.") | |
544 (where-is symbol))) | |
545 | |
546 ;;;###autoload | |
547 (defun hyper-describe-function (symbol &optional this-ref-buffer) | |
548 "Hypertext replacement for `describe-function'. Unlike `describe-function' | |
549 in that the symbol under the cursor is the default if it is a function. | |
550 See also `hyper-apropos' and `hyper-describe-variable'." | |
551 ;; #### - perhaps a prefix arg should suppress the prompt... | |
552 (interactive (list (hyper-apropos-read-function-symbol | |
553 (if (hyper-apropos-follow-ref-buffer current-prefix-arg) | |
554 "Follow function" | |
555 "Describe function")) | |
556 current-prefix-arg)) | |
557 (if (null symbol) | |
558 (message "Sorry, nothing to describe.") | |
559 (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) | |
560 (setq hyper-apropos-prev-wconfig (current-window-configuration))) | |
561 (hyper-apropos-get-doc symbol t nil this-ref-buffer))) | |
562 | |
563 ;;;###autoload | |
564 (defun hyper-apropos-read-variable-symbol (prompt &optional predicate) | |
565 "Hypertext drop-in replacement for `describe-variable'. | |
566 See also `hyper-apropos' and `hyper-describe-function'." | |
567 ;; #### - perhaps a prefix arg should suppress the prompt... | |
568 (or predicate (setq predicate 'boundp)) | |
569 (let (v val) | |
570 (setq v (hyper-apropos-this-symbol)) ; symbol under point | |
571 (or (funcall predicate v) | |
572 (setq v (variable-at-point))) | |
573 (or (funcall predicate v) | |
574 (setq v nil)) | |
575 (setq val (let ((enable-recursive-minibuffers t)) | |
576 (completing-read | |
577 (concat prompt | |
578 (if v | |
579 (format " (default %s): " v) | |
580 ": ")) | |
438 | 581 obarray predicate t nil 'variable-history |
582 (and v (symbol-name v))))) | |
583 (intern-soft val))) | |
584 | |
428 | 585 ;;;###autoload |
586 (define-obsolete-function-alias | |
587 'hypropos-read-variable-symbol 'hyper-apropos-read-variable-symbol) | |
588 | |
589 (defun hyper-apropos-read-function-symbol (prompt) | |
590 "Read function symbol from minibuffer." | |
591 (let ((fn (hyper-apropos-this-symbol)) | |
592 val) | |
593 (or (fboundp fn) | |
594 (setq fn (function-at-point))) | |
595 (setq val (let ((enable-recursive-minibuffers t)) | |
596 (completing-read (if fn | |
597 (format "%s (default %s): " prompt fn) | |
598 (format "%s: " prompt)) | |
599 obarray 'fboundp t nil | |
438 | 600 'function-history |
601 (and fn (symbol-name fn))))) | |
602 (intern-soft val))) | |
428 | 603 |
604 (defun hyper-apropos-last-help (arg) | |
605 "Go back to the last symbol documented in the *Hyper Help* buffer." | |
606 (interactive "P") | |
607 (let ((win (get-buffer-window hyper-apropos-help-buf))) | |
608 (or arg (setq arg (if win 1 0))) | |
609 (cond ((= arg 0)) | |
610 ((<= (length hyper-apropos-help-history) arg) | |
611 ;; go back as far as we can... | |
612 (setcdr (nreverse hyper-apropos-help-history) nil)) | |
613 (t | |
614 (setq hyper-apropos-help-history | |
615 (nthcdr arg hyper-apropos-help-history)))) | |
616 (if (or win (> arg 0)) | |
617 (hyper-apropos-get-doc (car hyper-apropos-help-history) t) | |
618 (display-buffer hyper-apropos-help-buf)))) | |
619 | |
620 (defun hyper-apropos-insert-face (string &optional face) | |
621 "Insert STRING and fontify some parts with face `hyper-apropos-hyperlink'." | |
622 (let ((beg (point)) end) | |
623 (insert-face string (or face 'hyper-apropos-documentation)) | |
624 (setq end (point)) | |
625 (goto-char beg) | |
626 (while (re-search-forward | |
627 "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'" | |
628 end 'limit) | |
629 (let ((e (make-extent (match-beginning 1) (match-end 1)))) | |
630 (set-extent-face e 'hyper-apropos-hyperlink) | |
631 (set-extent-property e 'mouse-face 'highlight))) | |
632 (goto-char beg) | |
633 (while (re-search-forward | |
634 "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)" | |
635 end 'limit) | |
636 (let ((e (make-extent (match-beginning 1) (match-end 1)))) | |
637 (set-extent-face e 'hyper-apropos-hyperlink) | |
638 (set-extent-property e 'mouse-face 'highlight))))) | |
639 | |
640 (defun hyper-apropos-insert-keybinding (keys string) | |
641 (if keys | |
642 (insert " (" string " bound to \"" | |
643 (mapconcat 'key-description | |
644 (sort* keys #'< :key #'length) | |
645 "\", \"") | |
646 "\")\n"))) | |
647 | |
648 (defun hyper-apropos-insert-section-heading (alias-desc &optional desc) | |
649 (or desc (setq desc alias-desc | |
650 alias-desc nil)) | |
651 (if alias-desc | |
652 (setq desc (concat alias-desc | |
653 (if (memq (aref desc 0) | |
654 '(?a ?e ?i ?o ?u)) | |
655 ", an " ", a ") | |
656 desc))) | |
657 (aset desc 0 (upcase (aref desc 0))) ; capitalize | |
658 (goto-char (point-max)) | |
659 (newline 3) (delete-blank-lines) (newline 2) | |
660 (hyper-apropos-insert-face desc 'hyper-apropos-section-heading)) | |
661 | |
662 (defun hyper-apropos-insert-value (string symbol val) | |
663 (insert-face string 'hyper-apropos-heading) | |
664 (insert (if (symbol-value symbol) | |
665 (if (or (null val) (eq val t) (integerp val)) | |
666 (prog1 | |
667 (symbol-value symbol) | |
668 (set symbol nil)) | |
669 "see below") | |
670 "is void"))) | |
671 | |
672 (defun hyper-apropos-follow-ref-buffer (this-ref-buffer) | |
673 (and (not this-ref-buffer) | |
674 (eq major-mode 'hyper-apropos-help-mode) | |
675 hyper-apropos-ref-buffer | |
676 (buffer-live-p hyper-apropos-ref-buffer))) | |
677 | |
678 (defun hyper-apropos-get-alias (symbol alias-p next-symbol &optional use) | |
679 "Return (TERMINAL-SYMBOL . ALIAS-DESC)." | |
680 (let (aliases) | |
681 (while (funcall alias-p symbol) | |
682 (setq aliases (cons (if use (funcall use symbol) symbol) aliases)) | |
683 (setq symbol (funcall next-symbol symbol))) | |
684 (cons symbol | |
685 (and aliases | |
686 (concat "an alias for `" | |
687 (mapconcat 'symbol-name | |
688 (nreverse aliases) | |
689 "',\nwhich is an alias for `") | |
690 "'"))))) | |
691 | |
692 (defun hyper-apropos-get-doc (&optional symbol force type this-ref-buffer) | |
693 ;; #### - update this docstring | |
694 "Toggle display of documentation for the symbol on the current line." | |
695 ;; SYMBOL is the symbol to document. FORCE, if non-nil, means to | |
696 ;; regenerate the documentation even if it already seems to be there. And | |
697 ;; TYPE, if present, forces the generation of only variable documentation | |
698 ;; or only function documentation. Normally, if both are present, then | |
699 ;; both will be generated. | |
700 ;; | |
701 ;; TYPES TO IMPLEMENT: obsolete face | |
702 ;; | |
703 (interactive) | |
704 (or symbol | |
705 (setq symbol (hyper-apropos-this-symbol))) | |
706 (or type | |
707 (setq type '(function variable face))) | |
708 (if (and (eq hyper-apropos-currently-showing symbol) | |
709 (get-buffer hyper-apropos-help-buf) | |
710 (get-buffer-window hyper-apropos-help-buf) | |
711 (not force)) | |
712 ;; we're already displaying this help, so toggle its display. | |
713 (delete-windows-on hyper-apropos-help-buf) | |
714 ;; OK, we've got to refresh and display it... | |
715 (or (eq symbol (car hyper-apropos-help-history)) | |
716 (setq hyper-apropos-help-history | |
717 (if (eq major-mode 'hyper-apropos-help-mode) | |
718 ;; if we're following a link in the help buffer, then | |
719 ;; record that in the help history. | |
720 (cons symbol hyper-apropos-help-history) | |
721 ;; otherwise clear the history because it's a new search. | |
722 (list symbol)))) | |
723 (save-excursion | |
724 (if (hyper-apropos-follow-ref-buffer this-ref-buffer) | |
725 (set-buffer hyper-apropos-ref-buffer) | |
726 (setq hyper-apropos-ref-buffer (current-buffer))) | |
727 (let (standard-output | |
728 ok beg | |
729 newsym symtype doc obsolete | |
730 (local mode-name) | |
731 global local-str global-str | |
732 font fore back undl | |
5173
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
733 aliases alias-desc desc arglist) |
428 | 734 (save-excursion |
735 (set-buffer (get-buffer-create hyper-apropos-help-buf)) | |
736 ;;(setq standard-output (current-buffer)) | |
737 (setq buffer-read-only nil) | |
738 (erase-buffer) | |
739 (insert-face (format "`%s'" symbol) 'hyper-apropos-major-heading) | |
740 (insert (format " (buffer: %s, mode: %s)\n" | |
741 (buffer-name hyper-apropos-ref-buffer) | |
742 local))) | |
743 ;; function ---------------------------------------------------------- | |
744 (and (memq 'function type) | |
745 (fboundp symbol) | |
746 (progn | |
747 (setq ok t) | |
748 (setq aliases (hyper-apropos-get-alias (symbol-function symbol) | |
749 'symbolp | |
750 'symbol-function) | |
751 newsym (car aliases) | |
752 alias-desc (cdr aliases)) | |
753 (if (eq 'macro (car-safe newsym)) | |
754 (setq desc "macro" | |
755 newsym (cdr newsym)) | |
756 (setq desc "function")) | |
757 (setq symtype (cond ((subrp newsym) 'subr) | |
758 ((compiled-function-p newsym) 'bytecode) | |
759 ((eq (car-safe newsym) 'autoload) 'autoload) | |
760 ((eq (car-safe newsym) 'lambda) 'lambda)) | |
761 desc (concat (if (commandp symbol) "interactive ") | |
762 (cdr (assq symtype | |
763 '((subr . "built-in ") | |
764 (bytecode . "compiled Lisp ") | |
765 (autoload . "autoloaded Lisp ") | |
766 (lambda . "Lisp ")))) | |
5173
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
767 desc ",\n(loaded from \"" |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
768 (or (symbol-file symbol 'defun) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
769 "[no file information available]") |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
770 "\")") |
428 | 771 local (current-local-map) |
772 global (current-global-map) | |
773 obsolete (get symbol 'byte-obsolete-info) | |
5173
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
774 doc (function-documentation symbol t) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
775 arglist (replace-in-string |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
776 (function-arglist symbol) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
777 (format "^(%s " |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
778 (regexp-quote (symbol-name symbol))) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
779 "(")) |
428 | 780 (save-excursion |
781 (set-buffer hyper-apropos-help-buf) | |
782 (goto-char (point-max)) | |
783 (setq standard-output (current-buffer)) | |
784 (hyper-apropos-insert-section-heading alias-desc desc) | |
785 (insert ":\n") | |
786 (if local | |
787 (hyper-apropos-insert-keybinding | |
788 (where-is-internal symbol (list local) nil nil nil) | |
789 "locally")) | |
790 (hyper-apropos-insert-keybinding | |
791 (where-is-internal symbol (list global) nil nil nil) | |
792 "globally") | |
793 (insert "\n") | |
794 (if obsolete | |
795 (hyper-apropos-insert-face | |
796 (format "%s is an obsolete function; %s\n\n" symbol | |
797 (if (stringp (car obsolete)) | |
798 (car obsolete) | |
799 (format "use `%s' instead." (car obsolete)))) | |
800 'hyper-apropos-warning)) | |
801 (setq beg (point)) | |
802 (insert-face "arguments: " 'hyper-apropos-heading) | |
5173
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
803 (princ arglist) |
428 | 804 (insert "\n\n") |
805 (hyper-apropos-insert-face doc) | |
806 (insert "\n") | |
807 (indent-rigidly beg (point) 2)))) | |
808 ;; variable ---------------------------------------------------------- | |
809 (and (memq 'variable type) | |
810 (or (boundp symbol) (default-boundp symbol)) | |
811 (progn | |
812 (setq ok t) | |
813 (setq aliases (hyper-apropos-get-alias symbol | |
814 'variable-alias | |
815 'variable-alias | |
816 'variable-alias) | |
817 newsym (car aliases) | |
818 alias-desc (cdr aliases)) | |
819 (setq symtype (or (local-variable-p newsym (current-buffer)) | |
820 (and (local-variable-p newsym | |
821 (current-buffer) t) | |
822 'auto-local)) | |
823 desc (concat (and (get newsym 'custom-type) | |
824 "customizable ") | |
825 (if (user-variable-p newsym) | |
826 "user variable" | |
827 "variable") | |
828 (cond ((eq symtype t) ", buffer-local") | |
829 ((eq symtype 'auto-local) | |
830 ", local when set"))) | |
831 local (and (boundp newsym) | |
832 (symbol-value newsym)) | |
833 local-str (and (boundp newsym) | |
834 (prin1-to-string local)) | |
835 global (and (eq symtype t) | |
836 (default-boundp newsym) | |
837 (default-value newsym)) | |
838 global-str (and (eq symtype t) | |
839 (default-boundp newsym) | |
840 (prin1-to-string global)) | |
841 obsolete (get symbol 'byte-obsolete-variable) | |
842 doc (or (documentation-property symbol | |
843 'variable-documentation) | |
844 "variable not documented")) | |
845 (save-excursion | |
846 (set-buffer hyper-apropos-help-buf) | |
847 (goto-char (point-max)) | |
848 (setq standard-output (current-buffer)) | |
849 (hyper-apropos-insert-section-heading alias-desc desc) | |
850 (when (and (user-variable-p newsym) | |
851 (get newsym 'custom-type)) | |
852 (let ((e (make-extent (point-at-bol) (point)))) | |
853 (set-extent-property e 'mouse-face 'highlight) | |
854 (set-extent-property e 'help-echo | |
855 (format "Customize %s" newsym)) | |
856 (set-extent-property | |
857 e 'hyper-apropos-custom | |
858 `(lambda () (customize-variable (quote ,newsym)))))) | |
859 (insert ":\n\n") | |
860 (setq beg (point)) | |
861 (if obsolete | |
862 (hyper-apropos-insert-face | |
863 (format "%s is an obsolete function; %s\n\n" symbol | |
864 (if (stringp obsolete) | |
865 obsolete | |
866 (format "use `%s' instead." obsolete))) | |
867 'hyper-apropos-warning)) | |
868 ;; generally, the value of the variable is short and the | |
869 ;; documentation of the variable long, so it's desirable | |
870 ;; to see all of the value and the start of the | |
871 ;; documentation. Some variables, though, have huge and | |
872 ;; nearly meaningless values that force you to page | |
873 ;; forward just to find the doc string. That is | |
874 ;; undesirable. | |
875 (if (and (or (null local-str) (< (length local-str) 69)) | |
876 (or (null global-str) (< (length global-str) 69))) | |
877 ; 80 cols. docstrings assume this. | |
878 (progn (insert-face "value: " 'hyper-apropos-heading) | |
879 (insert (or local-str "is void")) | |
880 (if (eq symtype t) | |
881 (progn | |
882 (insert "\n") | |
883 (insert-face "default value: " 'hyper-apropos-heading) | |
884 (insert (or global-str "is void")))) | |
885 (insert "\n\n") | |
886 (hyper-apropos-insert-face doc)) | |
887 (hyper-apropos-insert-value "value: " 'local-str local) | |
888 (if (eq symtype t) | |
889 (progn | |
890 (insert ", ") | |
891 (hyper-apropos-insert-value "default-value: " | |
892 'global-str global))) | |
893 (insert "\n\n") | |
894 (hyper-apropos-insert-face doc) | |
895 (if local-str | |
896 (progn | |
897 (newline 3) (delete-blank-lines) (newline 1) | |
898 (insert-face "value: " 'hyper-apropos-heading) | |
899 (if hyper-apropos-prettyprint-long-values | |
900 (condition-case nil | |
901 (cl-prettyprint local) | |
902 (error (insert local-str))) | |
903 (insert local-str)))) | |
904 (if global-str | |
905 (progn | |
906 (newline 3) (delete-blank-lines) (newline 1) | |
907 (insert-face "default value: " 'hyper-apropos-heading) | |
908 (if hyper-apropos-prettyprint-long-values | |
909 (condition-case nil | |
910 (cl-prettyprint global) | |
911 (error (insert global-str))) | |
912 (insert global-str))))) | |
913 (indent-rigidly beg (point) 2)))) | |
914 ;; face -------------------------------------------------------------- | |
915 (and (memq 'face type) | |
916 (find-face symbol) | |
917 (progn | |
918 (setq ok t) | |
919 (copy-face symbol 'hyper-apropos-temp-face 'global) | |
5173
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
920 (mapc #'(lambda (property) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
921 (setq symtype (face-property-instance symbol |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
922 property)) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
923 (if symtype |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
924 (set-face-property 'hyper-apropos-temp-face |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
925 property |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
926 symtype))) |
bd1e25975cdc
Use #'function-arglist, etc. from help.el, not reimplementing them, hyper-apropos
Aidan Kehoe <kehoea@parhasard.net>
parents:
4695
diff
changeset
|
927 built-in-face-specifiers) |
428 | 928 (setq font (cons (face-property-instance symbol 'font nil 0 t) |
929 (face-property-instance symbol 'font)) | |
930 fore (cons (face-foreground-instance symbol nil 0 t) | |
931 (face-foreground-instance symbol)) | |
932 back (cons (face-background-instance symbol nil 0 t) | |
933 (face-background-instance symbol)) | |
934 undl (cons (face-underline-p symbol nil 0 t) | |
935 (face-underline-p symbol)) | |
936 doc (face-doc-string symbol)) | |
937 ;; #### - add some code here | |
938 (save-excursion | |
939 (set-buffer hyper-apropos-help-buf) | |
940 (setq standard-output (current-buffer)) | |
941 (hyper-apropos-insert-section-heading | |
942 (concat "Face" | |
943 (when (get symbol 'face-defface-spec) | |
944 (let* ((str " (customizable)") | |
945 (e (make-extent 1 (length str) str))) | |
946 (set-extent-property e 'mouse-face 'highlight) | |
947 (set-extent-property e 'help-echo | |
948 (format "Customize %s" symbol)) | |
949 (set-extent-property e 'unique t) | |
950 (set-extent-property e 'duplicable t) | |
951 (set-extent-property | |
952 e 'hyper-apropos-custom | |
953 `(lambda () (customize-face (quote ,symbol)))) | |
954 str)) | |
955 ":\n\n ")) | |
956 (insert-face "\ | |
957 ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789" | |
958 'hyper-apropos-temp-face) | |
959 (newline 2) | |
960 (insert-face " Font: " 'hyper-apropos-heading) | |
961 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n") | |
962 (and (cdr font) | |
963 (font-instance-name (cdr font))))) | |
964 (insert-face " Foreground: " 'hyper-apropos-heading) | |
965 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n") | |
966 (and (cdr fore) | |
967 (color-instance-name (cdr fore))))) | |
968 (insert-face " Background: " 'hyper-apropos-heading) | |
969 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n") | |
970 (and (cdr back) | |
971 (color-instance-name (cdr back))))) | |
972 (insert-face " Underline: " 'hyper-apropos-heading) | |
973 (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n") | |
974 (cdr undl))) | |
975 (if doc | |
976 (progn | |
977 (newline) | |
978 (setq beg (point)) | |
979 (insert doc) | |
980 (indent-rigidly beg (point) 2)))))) | |
981 ;; not bound & property list ----------------------------------------- | |
982 (or ok | |
983 (save-excursion | |
984 (set-buffer hyper-apropos-help-buf) | |
985 (hyper-apropos-insert-section-heading | |
986 "symbol is not currently bound\n"))) | |
987 (if (and (setq symtype (symbol-plist symbol)) | |
988 (or (> (length symtype) 2) | |
989 (not (memq 'variable-documentation symtype)))) | |
990 (save-excursion | |
991 (set-buffer hyper-apropos-help-buf) | |
992 (goto-char (point-max)) | |
993 (setq standard-output (current-buffer)) | |
994 (hyper-apropos-insert-section-heading "property-list:\n\n") | |
995 (while symtype | |
996 (if (memq (car symtype) | |
997 '(variable-documentation byte-obsolete-info)) | |
998 (setq symtype (cdr symtype)) | |
999 (insert-face (concat " " (symbol-name (car symtype)) | |
1000 ": ") | |
1001 'hyper-apropos-heading) | |
1002 (setq symtype (cdr symtype)) | |
1003 (indent-to 32) | |
1004 (insert (prin1-to-string (car symtype)) "\n")) | |
1005 (setq symtype (cdr symtype))))))) | |
1006 (save-excursion | |
1007 (set-buffer hyper-apropos-help-buf) | |
1008 (goto-char (point-min)) | |
1009 ;; pop up window and shrink it if it's wasting space | |
1010 (if hyper-apropos-shrink-window | |
1011 (shrink-window-if-larger-than-buffer | |
1012 (display-buffer (current-buffer))) | |
1013 (display-buffer (current-buffer))) | |
1014 (hyper-apropos-help-mode)) | |
1015 (setq hyper-apropos-currently-showing symbol))) | |
1016 ;;;###autoload | |
1017 (define-obsolete-function-alias | |
1018 'hypropos-get-doc 'hyper-apropos-get-doc) | |
1019 | |
1020 ; ----------------------------------------------------------------------------- | |
1021 | |
1022 (defun hyper-apropos-help-mode () | |
1023 "Major mode for hypertext XEmacs help. In this mode, you can quickly | |
1024 follow links between back and forth between the documentation strings for | |
1025 different variables and functions. Common commands: | |
1026 | |
1027 \\{hyper-apropos-help-map}" | |
1028 (setq buffer-read-only t | |
1029 major-mode 'hyper-apropos-help-mode | |
1030 mode-name "Hyper-Help") | |
1031 (set-syntax-table emacs-lisp-mode-syntax-table) | |
1032 (use-local-map hyper-apropos-help-map)) | |
1033 | |
1034 ;; ---------------------------------------------------------------------- ;; | |
1035 | |
1036 (defun hyper-apropos-scroll-up () | |
1037 "Scroll up the \"*Hyper Help*\" buffer if it's visible. | |
1038 Otherwise, scroll the selected window up." | |
1039 (interactive) | |
1040 (let ((win (get-buffer-window hyper-apropos-help-buf)) | |
1041 (owin (selected-window))) | |
1042 (if win | |
1043 (progn | |
1044 (select-window win) | |
1045 (condition-case nil | |
1046 (scroll-up nil) | |
1047 (error (goto-char (point-max)))) | |
1048 (select-window owin)) | |
1049 (scroll-up nil)))) | |
1050 | |
1051 (defun hyper-apropos-scroll-down () | |
1052 "Scroll down the \"*Hyper Help*\" buffer if it's visible. | |
1053 Otherwise, scroll the selected window down." | |
1054 (interactive) | |
1055 (let ((win (get-buffer-window hyper-apropos-help-buf)) | |
1056 (owin (selected-window))) | |
1057 (if win | |
1058 (progn | |
1059 (select-window win) | |
1060 (condition-case nil | |
1061 (scroll-down nil) | |
1062 (error (goto-char (point-max)))) | |
1063 (select-window owin)) | |
1064 (scroll-down nil)))) | |
1065 | |
1066 ;; ---------------------------------------------------------------------- ;; | |
1067 | |
1068 (defun hyper-apropos-mouse-get-doc (event) | |
1069 "Get the documentation for the symbol the mouse is on." | |
1070 (interactive "e") | |
1071 (mouse-set-point event) | |
1072 (let ((e (extent-at (point) nil 'hyper-apropos-custom))) | |
1073 (if e | |
1074 (funcall (extent-property e 'hyper-apropos-custom)) | |
1075 (save-excursion | |
1076 (let ((symbol (hyper-apropos-this-symbol))) | |
1077 (if symbol | |
1078 (hyper-apropos-get-doc symbol) | |
1079 (error "Click on a symbol"))))))) | |
1080 | |
1081 ;; ---------------------------------------------------------------------- ;; | |
1082 | |
1083 (defun hyper-apropos-add-keyword (pattern) | |
1084 "Use additional keyword to narrow regexp match. | |
1085 Deletes lines which don't match PATTERN." | |
1086 (interactive "sAdditional Keyword: ") | |
1087 (save-excursion | |
1088 (goto-char (point-min)) | |
1089 (let (buffer-read-only) | |
1090 (keep-lines (concat pattern "\\|" hyper-apropos-junk-regexp)) | |
1091 ))) | |
1092 | |
1093 (defun hyper-apropos-eliminate-keyword (pattern) | |
1094 "Use additional keyword to eliminate uninteresting matches. | |
1095 Deletes lines which match PATTERN." | |
1096 (interactive "sKeyword to eliminate: ") | |
1097 (save-excursion | |
1098 (goto-char (point-min)) | |
1099 (let (buffer-read-only) | |
1100 (flush-lines pattern)) | |
1101 )) | |
1102 | |
1103 ;; ---------------------------------------------------------------------- ;; | |
1104 | |
1105 (defun hyper-apropos-this-symbol () | |
1106 (save-excursion | |
1107 (cond ((eq major-mode 'hyper-apropos-mode) | |
1108 (beginning-of-line) | |
1109 (if (looking-at hyper-apropos-junk-regexp) | |
1110 nil | |
1111 (forward-char 3) | |
1112 (read (point-marker)))) | |
444 | 1113 ;; What's this? This ends up in the same symbol already described. |
1114 ;; ((and | |
1115 ;; (eq major-mode 'hyper-apropos-help-mode) | |
1116 ;; (> (point) (point-min))) | |
1117 ;; (save-excursion | |
1118 ;; (goto-char (point-min)) | |
1119 ;; (hyper-apropos-this-symbol))) | |
428 | 1120 (t |
1121 (let* ((st (progn | |
1122 (skip-syntax-backward "w_") | |
1123 ;; !@(*$^%%# stupid backquote implementation!!! | |
1124 (skip-chars-forward "`") | |
1125 (point))) | |
1126 (en (progn | |
1127 (skip-syntax-forward "w_") | |
1128 (skip-chars-backward ".':") ; : for Local Variables | |
1129 (point)))) | |
1130 (and (not (eq st en)) | |
1131 (intern-soft (buffer-substring st en)))))))) | |
1132 | |
1133 (defun hyper-apropos-where-is (symbol) | |
1134 "Find keybinding for symbol on current line." | |
1135 (interactive (list (hyper-apropos-this-symbol))) | |
1136 (where-is symbol)) | |
1137 | |
1138 (defun hyper-apropos-invoke-fn (fn) | |
1139 "Interactively invoke the function on the current line." | |
1140 (interactive (list (hyper-apropos-this-symbol))) | |
1141 (cond ((not (fboundp fn)) | |
1142 (error "%S is not a function" fn)) | |
1143 (t (call-interactively fn)))) | |
1144 | |
1145 ;;;###autoload | |
1146 (defun hyper-set-variable (var val &optional this-ref-buffer) | |
1147 (interactive | |
1148 (let ((var (hyper-apropos-read-variable-symbol | |
1149 (if (hyper-apropos-follow-ref-buffer current-prefix-arg) | |
1150 "In ref buffer, set user option" | |
1151 "Set user option") | |
1152 'user-variable-p))) | |
1153 (list var (hyper-apropos-read-variable-value var) current-prefix-arg))) | |
1154 (hyper-apropos-set-variable var val this-ref-buffer)) | |
1155 | |
1156 ;;;###autoload | |
1157 (defun hyper-apropos-set-variable (var val &optional this-ref-buffer) | |
1158 "Interactively set the variable on the current line." | |
1159 (interactive | |
1160 (let ((var (hyper-apropos-this-symbol))) | |
1161 (or (and var (boundp var)) | |
1162 (setq var nil)) | |
1163 (list var (hyper-apropos-read-variable-value var)))) | |
1164 (and var | |
1165 (boundp var) | |
1166 (progn | |
1167 (if (hyper-apropos-follow-ref-buffer this-ref-buffer) | |
1168 (save-excursion | |
1169 (set-buffer hyper-apropos-ref-buffer) | |
1170 (set var val)) | |
1171 (set var val)) | |
1172 (hyper-apropos-get-doc var t '(variable) this-ref-buffer)))) | |
1173 ;;;###autoload | |
1174 (define-obsolete-function-alias | |
1175 'hypropos-set-variable 'hyper-apropos-set-variable) | |
1176 | |
1177 (defun hyper-apropos-read-variable-value (var &optional this-ref-buffer) | |
1178 (and var | |
1179 (boundp var) | |
1180 (let ((prop (get var 'variable-interactive)) | |
1181 (print-readably t) | |
1182 val str) | |
1183 (hyper-apropos-get-doc var t '(variable) current-prefix-arg) | |
1184 (if prop | |
1185 (call-interactively (list 'lambda '(arg) | |
1186 (list 'interactive prop) | |
1187 'arg)) | |
1188 (setq val (if (hyper-apropos-follow-ref-buffer this-ref-buffer) | |
1189 (save-excursion | |
1190 (set-buffer hyper-apropos-ref-buffer) | |
1191 (symbol-value var)) | |
1192 (symbol-value var)) | |
1193 str (prin1-to-string val)) | |
1194 (eval-minibuffer | |
1195 (format "Set %s `%s' to value (evaluated): " | |
1196 (if (user-variable-p var) "user option" "Variable") | |
1197 var) | |
1198 (condition-case nil | |
1199 (progn | |
1200 (read str) | |
1201 (format (if (or (consp val) | |
1202 (and (symbolp val) | |
1203 (not (memq val '(t nil))))) | |
1204 "'%s" "%s") | |
1205 str)) | |
1206 (error nil))))))) | |
1207 | |
1208 (defun hyper-apropos-customize-variable () | |
1209 (interactive) | |
1210 (let ((var (hyper-apropos-this-symbol))) | |
430 | 1211 (and |
1212 (or (and var (boundp var)) | |
1213 (setq var nil)) | |
1214 (customize-variable var)))) | |
428 | 1215 |
1216 ;; ---------------------------------------------------------------------- ;; | |
1217 | |
1218 (defun hyper-apropos-find-tag (&optional tag-name) | |
1219 "Find the tag for the symbol on the current line in other window. In | |
1220 order for this to work properly, the variable `tag-table-alist' or | |
1221 `tags-file-name' must be set so that a TAGS file with tags for the emacs | |
1222 source is found for the \"*Hyper Apropos*\" buffer." | |
1223 (interactive) | |
1224 ;; there ought to be a default tags file for this... | |
1225 (or tag-name (setq tag-name (symbol-name (hyper-apropos-this-symbol)))) | |
1226 (find-tag-other-window (list tag-name))) | |
1227 | |
1228 ;; ---------------------------------------------------------------------- ;; | |
1229 | |
1230 (defun hyper-apropos-find-function (fn) | |
1231 "Find the function for the symbol on the current line in other | |
1232 window. (See also `find-function'.)" | |
1233 (interactive | |
1234 (let ((fn (hyper-apropos-this-symbol))) | |
1235 (or (fboundp fn) | |
1236 (setq fn nil)) | |
1237 (list fn))) | |
1238 (if fn | |
776 | 1239 (if-fboundp 'find-function-other-window |
1240 (find-function-other-window fn) | |
1241 (error 'unimplemented "`find-func' package unavailable")))) | |
428 | 1242 |
718 | 1243 (defun hyper-apropos-find-variable (fn) |
1244 "Find the variable for the symbol on the current line in other | |
1245 window. (See also `find-variable'.)" | |
1246 (interactive | |
1247 (let ((fn (hyper-apropos-this-symbol))) | |
1248 (or (boundp fn) | |
1249 (setq fn nil)) | |
1250 (list fn))) | |
1251 (if fn | |
776 | 1252 (if-fboundp 'find-variable-other-window |
1253 (find-variable-other-window fn) | |
1254 (error 'unimplemented "`find-func' package unavailable")))) | |
718 | 1255 |
428 | 1256 ;; ---------------------------------------------------------------------- ;; |
1257 | |
1258 (defun hyper-apropos-disassemble (sym) | |
1259 "Disassemble FUN if it is byte-coded. If it's a lambda, prettyprint it." | |
1260 (interactive (list (hyper-apropos-this-symbol))) | |
1261 (let ((fun sym) (trail nil) macrop) | |
1262 (while (and (symbolp fun) (not (memq fun trail))) | |
1263 (setq trail (cons fun trail) | |
1264 fun (symbol-function fun))) | |
1265 (and (symbolp fun) | |
1266 (error "Loop detected in function binding of `%s'" fun)) | |
1267 (setq macrop (and (consp fun) | |
1268 (eq 'macro (car fun)))) | |
1269 (cond ((compiled-function-p (if macrop (cdr fun) fun)) | |
1270 (disassemble fun) | |
1271 (set-buffer "*Disassemble*") | |
1272 (goto-char (point-min)) | |
1273 (forward-sexp 2) | |
1274 (insert (format " for function `%S'" sym)) | |
1275 ) | |
1276 ((consp fun) | |
1277 (with-current-buffer "*Disassemble*" | |
1278 (cl-prettyprint (if macrop | |
1279 (cons 'defmacro (cons sym (cdr (cdr fun)))) | |
1280 (cons 'defun (cons sym (cdr fun)))))) | |
1281 (set-buffer "*Disassemble*") | |
1282 (emacs-lisp-mode)) | |
1283 ((or (vectorp fun) (stringp fun)) | |
1284 ;; #### - do something fancy here | |
1285 (with-output-to-temp-buffer "*Disassemble*" | |
1286 (princ (format "%s is a keyboard macro:\n\n\t" sym)) | |
1287 (prin1 fun))) | |
1288 (t | |
1289 (error "Sorry, cannot disassemble `%s'" sym))))) | |
1290 | |
1291 ;; ---------------------------------------------------------------------- ;; | |
1292 | |
1293 (defun hyper-apropos-quit () | |
1294 (interactive) | |
1295 "Quit Hyper Apropos and restore original window config." | |
1296 (let ((buf (get-buffer hyper-apropos-apropos-buf))) | |
1297 (and buf (bury-buffer buf))) | |
1298 (set-window-configuration hyper-apropos-prev-wconfig)) | |
1299 | |
1300 ;; ---------------------------------------------------------------------- ;; | |
1301 | |
1302 ;;;###autoload | |
1303 (defun hyper-apropos-popup-menu (event) | |
1304 (interactive "e") | |
1305 (mouse-set-point event) | |
430 | 1306 (let* ((sym (hyper-apropos-this-symbol)) |
428 | 1307 (notjunk (not (null sym))) |
1308 (command-p (if (commandp sym) t)) | |
1309 (variable-p (and sym (boundp sym))) | |
1310 (customizable-p (and variable-p | |
1311 (get sym 'custom-type) | |
1312 t)) | |
1313 (function-p (fboundp sym)) | |
1314 (apropos-p (eq 'hyper-apropos-mode | |
1315 (save-excursion (set-buffer (event-buffer event)) | |
1316 major-mode))) | |
1317 (name (if sym (symbol-name sym) "")) | |
1318 (hyper-apropos-menu | |
1319 (delete | |
1320 nil | |
1321 (list (concat "Hyper-Help: " name) | |
1322 (vector "Display documentation" 'hyper-apropos-get-doc notjunk) | |
1323 (vector "Set variable" 'hyper-apropos-set-variable variable-p) | |
1324 (vector "Customize variable" 'hyper-apropos-customize-variable | |
1325 customizable-p) | |
1326 (vector "Show keys for" 'hyper-apropos-where-is command-p) | |
1327 (vector "Invoke command" 'hyper-apropos-invoke-fn command-p) | |
1039 | 1328 (vector "Find function" 'hyper-apropos-find-function function-p) |
1329 (vector "Find variable" 'hyper-apropos-find-variable variable-p) | |
428 | 1330 (vector "Find tag" 'hyper-apropos-find-tag notjunk) |
1331 (and apropos-p | |
1332 ["Add keyword..." hyper-apropos-add-keyword t]) | |
1333 (and apropos-p | |
1334 ["Eliminate keyword..." hyper-apropos-eliminate-keyword t]) | |
1335 (if apropos-p | |
1336 ["Programmers' Apropos" hyper-apropos-toggle-programming-flag | |
1337 :style toggle :selected hyper-apropos-programming-apropos] | |
1338 ["Programmers' Help" hyper-apropos-toggle-programming-flag | |
1339 :style toggle :selected hyper-apropos-programming-apropos]) | |
1340 (and hyper-apropos-programming-apropos | |
1341 (vector "Disassemble function" | |
1342 'hyper-apropos-disassemble | |
1343 function-p)) | |
1344 ["Help" describe-mode t] | |
1345 ["Quit" hyper-apropos-quit t] | |
1346 )))) | |
1347 (popup-menu hyper-apropos-menu))) | |
1348 ;;;###autoload | |
1349 (define-obsolete-function-alias | |
1350 'hypropos-popup-menu 'hyper-apropos-popup-menu) | |
1351 | |
1352 (provide 'hyper-apropos) | |
1353 | |
1354 ;; end of hyper-apropos.el |