|
0
|
1 ;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
|
|
|
4 ;; Copyright (C) 1995 Sun Microsystems.
|
|
|
5 ;; Copyright (C) 1996 Ben Wing.
|
|
|
6
|
|
|
7 ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
|
|
|
8 ;; Keywords: lisp, tools, help, docs, matching
|
|
|
9
|
|
|
10 ;; This file is part of XEmacs.
|
|
|
11
|
|
|
12 ;; XEmacs is free software; you can redistribute it and/or modify
|
|
|
13 ;; it under the terms of the GNU General Public License as published by
|
|
|
14 ;; the Free Software Foundation; either version 2 of the License, or
|
|
|
15 ;; (at your option) any later version.
|
|
|
16 ;;
|
|
|
17 ;; XEmacs is distributed in the hope that it will be useful,
|
|
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
20 ;; GNU General Public License for more details.
|
|
|
21 ;;
|
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
|
23 ;; along with XEmacs; if not, write to the Free Software
|
|
|
24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
25
|
|
|
26 ;;; Synched up with: Not in FSF.
|
|
|
27
|
|
|
28 ;;; Commentary:
|
|
|
29
|
|
|
30 ;; based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
|
|
|
31 ;;
|
|
|
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.
|
|
|
35 ;;
|
|
|
36 ;; This version of apropos prints two lists of symbols matching the
|
|
|
37 ;; given regexp: functions/macros and variables/constants.
|
|
|
38 ;;
|
|
|
39 ;; The user can then do the following:
|
|
|
40 ;;
|
|
|
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
|
|
|
45 ;; - invoke functions
|
|
|
46 ;; - set variables
|
|
|
47 ;;
|
|
|
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).
|
|
|
51 ;;
|
|
|
52 ;; Mouse bindings and menus are provided for XEmacs.
|
|
|
53 ;;
|
|
|
54 ;; additions by Ben Wing <wing@666.com> July 1995:
|
|
|
55 ;; added support for function aliases, made programmer's apropos be the
|
|
|
56 ;; default, various other hacking.
|
|
|
57
|
|
|
58 ;;; Code:
|
|
|
59
|
|
|
60 (or (fboundp 'pprint)
|
|
|
61 (progn (autoload 'pp "pp")
|
|
|
62 (fset 'pprint 'pp)))
|
|
|
63 ;;(require 'tags "etags")
|
|
|
64
|
|
|
65 ;;;###autoload
|
|
|
66 (defvar hypropos-show-brief-docs t
|
|
|
67 "*If non-nil, `hyper-apropos' will display some documentation in the
|
|
|
68 \"*Hyper Apropos*\" buffer. Setting this to nil will speed up searches.")
|
|
|
69
|
|
|
70 (defvar hypropos-prettyprint-long-values t
|
|
|
71 "*If non-nil, then try to beautify the printing of very long values.")
|
|
|
72
|
|
|
73 ;; I changed this to true because I think it's more useful this way. --ben
|
|
|
74
|
|
|
75 (defvar hypropos-programming-apropos t
|
|
|
76 "*If non-nil, then `hyper-apropos' takes a bit longer and generates more
|
|
|
77 output. If nil, then only functions that are interactive and variables that
|
|
|
78 are user variables are found by `hyper-apropos'.")
|
|
|
79
|
|
|
80 (defvar hypropos-prev-wconfig)
|
|
|
81
|
|
|
82 ;; #### - move this to subr.el
|
|
|
83 (or (fboundp 'event-buffer)
|
|
|
84 (defun event-buffer (event)
|
|
|
85 "Returns the buffer associated with event, or nil."
|
|
|
86 (let ((win (event-window event)))
|
|
|
87 (and win (window-buffer win)))))
|
|
|
88
|
|
|
89 (defmacro eval-in-buffer (buffer &rest forms)
|
|
|
90 "Evaluate FORMS in BUFFER."
|
|
|
91 (` (let ((_unwind_buf_ (current-buffer)))
|
|
|
92 (unwind-protect
|
|
|
93 (progn (set-buffer (, buffer))
|
|
|
94 (,@ forms))
|
|
|
95 (set-buffer _unwind_buf_)))))
|
|
|
96 (put 'eval-in-buffer 'lisp-indent-function 'defun)
|
|
|
97
|
|
|
98 ;; #### - move to faces.el
|
|
|
99 (defmacro init-face (face &rest init-forms)
|
|
|
100 "Make a FACE if it doesn't already exist. Then if it does not differ from
|
|
|
101 the default face, execute INIT-FORMS to initialize the face. While the
|
|
|
102 init-forms are executing, the symbol `this' is bound to the face-object
|
|
|
103 being initialized."
|
|
|
104 (` (let ((this (make-face (, face)))) ; harmless if the face is already there
|
|
|
105 (or (face-differs-from-default-p this)
|
|
|
106 (, (cons 'progn init-forms))))))
|
|
|
107 (put 'init-face 'lisp-indent-function 'defun)
|
|
|
108
|
|
|
109 (init-face 'hyperlink
|
|
|
110 (copy-face 'bold this)
|
|
|
111 ;;(set-face-underline-p this nil) -- dog slow and ugly
|
|
|
112 (condition-case nil
|
|
|
113 (set-face-foreground this "blue")
|
|
|
114 (error nil)))
|
|
|
115 (init-face 'documentation
|
|
|
116 (let* ((ff-instance (face-font-instance 'default))
|
|
|
117 (ff (and ff-instance (font-instance-name ff-instance))))
|
|
|
118 (cond ((and ff (string-match "courier" ff))
|
|
|
119 ;; too wide unless you shrink it
|
|
|
120 ;; (copy-face 'italic this) fugly.
|
|
|
121 ;; (make-face-smaller this) fugly.
|
|
|
122 ))
|
|
|
123 (condition-case nil
|
|
|
124 (set-face-foreground this "firebrick")
|
|
|
125 (error (copy-face 'italic this)))))
|
|
|
126
|
|
|
127 ;; mucking with the sizes of fonts (perhaps with the exception of courier or
|
|
|
128 ;; misc) is a generally losing thing to do. Changing the size of 'clean'
|
|
|
129 ;; really loses, for instance...
|
|
|
130
|
|
|
131 (init-face 'major-heading
|
|
|
132 (copy-face 'bold this)
|
|
|
133 (make-face-larger this)
|
|
|
134 (make-face-larger this))
|
|
|
135 (init-face 'section-heading
|
|
|
136 (copy-face 'bold this)
|
|
|
137 (make-face-larger this))
|
|
|
138 (init-face 'heading
|
|
|
139 (copy-face 'bold this))
|
|
|
140 (init-face 'standout
|
|
|
141 (copy-face 'italic this))
|
|
|
142
|
|
|
143 (init-face 'warning
|
|
|
144 (copy-face 'bold this)
|
|
|
145 (and (eq (device-type) 'x)
|
|
|
146 (eq (device-class) 'color)
|
|
|
147 (set-face-foreground this "red")))
|
|
|
148
|
|
|
149 (defvar hypropos-help-map (let ((map (make-sparse-keymap)))
|
|
|
150 (suppress-keymap map)
|
|
|
151 (set-keymap-name map 'hypropos-help-map)
|
|
|
152 ;; movement
|
|
|
153 (define-key map " " 'scroll-up)
|
|
|
154 (define-key map "b" 'scroll-down)
|
|
|
155 (define-key map "/" 'isearch-forward)
|
|
|
156 (define-key map "?" 'isearch-backward)
|
|
|
157 ;; follow links
|
|
|
158 (define-key map "\r" 'hypropos-get-doc)
|
|
|
159 (define-key map "s" 'hypropos-set-variable)
|
|
|
160 (define-key map "t" 'hypropos-find-tag)
|
|
|
161 (define-key map "l" 'hypropos-last-help)
|
|
|
162 (define-key map [button2] 'hypropos-mouse-get-doc)
|
|
|
163 (define-key map [button3] 'hypropos-popup-menu)
|
|
|
164 ;; for the totally hardcore...
|
|
|
165 (define-key map "D" 'hypropos-disassemble)
|
|
|
166 ;; administrativa
|
|
|
167 (define-key map "a" 'hyper-apropos)
|
|
|
168 (define-key map "n" 'hyper-apropos)
|
|
|
169 (define-key map "q" 'hypropos-quit)
|
|
|
170 map
|
|
|
171 )
|
|
|
172 "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer")
|
|
|
173
|
|
|
174 (defvar hypropos-map (let ((map (make-sparse-keymap)))
|
|
|
175 (set-keymap-name map 'hypropos-map)
|
|
|
176 (set-keymap-parents map (list hypropos-help-map))
|
|
|
177 ;; slightly differrent scrolling...
|
|
|
178 (define-key map " " 'hypropos-scroll-up)
|
|
|
179 (define-key map "b" 'hypropos-scroll-down)
|
|
|
180 ;; act on the current line...
|
|
|
181 (define-key map "w" 'hypropos-where-is)
|
|
|
182 (define-key map "i" 'hypropos-invoke-fn)
|
|
|
183 (define-key map "s" 'hypropos-set-variable)
|
|
|
184 ;; more administrativa...
|
|
|
185 (define-key map "P" 'hypropos-toggle-programming-flag)
|
|
|
186 (define-key map "k" 'hypropos-add-keyword)
|
|
|
187 (define-key map "e" 'hypropos-eliminate-keyword)
|
|
|
188 map
|
|
|
189 )
|
|
|
190 "Keybindings for the *Hyper Apropos* buffer.
|
|
|
191 This map inherits from `hypropos-help-map.'")
|
|
|
192
|
|
|
193 (defvar hyper-apropos-mode-hook nil
|
|
|
194 "*User function run after hyper-apropos mode initialization. Usage:
|
|
|
195 \(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).")
|
|
|
196
|
|
|
197 ;; ---------------------------------------------------------------------- ;;
|
|
|
198
|
|
|
199 (defconst hypropos-junk-regexp "^Apropos\\|^Functions\\|^Variables\\|^$")
|
|
|
200
|
|
|
201 (defvar hypropos-currently-showing nil) ; symbol documented in help buffer now
|
|
|
202 (defvar hypropos-help-history nil) ; chain of symbols followed as links in
|
|
|
203 ; help buffer
|
|
|
204 (defvar hypropos-last-regexp nil) ; regex used for last apropos
|
|
|
205 (defconst hypropos-apropos-buf "*Hyper Apropos*")
|
|
|
206 (defconst hypropos-help-buf "*Hyper Help*")
|
|
|
207
|
|
|
208 ;;;###autoload
|
|
|
209 (defun hyper-apropos (regexp toggle-apropos)
|
|
|
210 "Display lists of functions and variables matching REGEXP
|
|
|
211 in buffer \"*Hyper Apropos*\". If optional prefix arg is given, then the value
|
|
|
212 of `hypropos-programming-apropos' is toggled for this search.
|
|
|
213 See also `hyper-apropos-mode'."
|
|
|
214 (interactive "sList symbols matching regexp: \nP")
|
|
|
215 (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
|
|
|
216 (setq hypropos-prev-wconfig (current-window-configuration)))
|
|
|
217 (if (string= "" regexp)
|
|
|
218 (if (get-buffer hypropos-apropos-buf)
|
|
|
219 (if toggle-apropos
|
|
|
220 (hypropos-toggle-programming-flag)
|
|
|
221 (message "Using last search results"))
|
|
|
222 (error "Be more specific..."))
|
|
|
223 (let (flist vlist)
|
|
|
224 (set-buffer (get-buffer-create hypropos-apropos-buf))
|
|
|
225 (setq buffer-read-only nil)
|
|
|
226 (erase-buffer)
|
|
|
227 (if toggle-apropos
|
|
|
228 (set (make-local-variable 'hypropos-programming-apropos)
|
|
|
229 (not (default-value 'hypropos-programming-apropos))))
|
|
|
230 (if (not hypropos-programming-apropos)
|
|
|
231 (setq flist (apropos-internal regexp 'commandp)
|
|
|
232 vlist (apropos-internal regexp 'user-variable-p))
|
|
|
233 ;; #### - add obsolete functions/variables here...
|
|
|
234 ;; #### - 'variables' may be unbound !!!
|
|
|
235 (setq flist (apropos-internal regexp 'fboundp)
|
|
|
236 vlist (apropos-internal regexp 'boundp)))
|
|
|
237 (insert-face (format "Apropos search for: %S\n\n" regexp) 'major-heading)
|
|
|
238 (insert-face "* = command (M-x) or user-variable.\n" 'documentation)
|
|
|
239 (insert-face "a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n" 'documentation)
|
|
|
240 (insert-face "Functions and Macros:\n\n" 'major-heading)
|
|
|
241 (hypropos-grok-functions flist)
|
|
|
242 (insert-face "\n\nVariables and Constants:\n\n" 'major-heading)
|
|
|
243 (hypropos-grok-variables vlist)
|
|
|
244 (goto-char (point-min))
|
|
|
245 ))
|
|
|
246 (switch-to-buffer hypropos-apropos-buf)
|
|
|
247 (hyper-apropos-mode regexp))
|
|
|
248
|
|
|
249 (defun hypropos-toggle-programming-flag ()
|
|
|
250 (interactive)
|
|
|
251 (eval-in-buffer hypropos-apropos-buf
|
|
|
252 (set (make-local-variable 'hypropos-programming-apropos)
|
|
|
253 (not hypropos-programming-apropos)))
|
|
|
254 (message "Re-running apropos...")
|
|
|
255 (hyper-apropos hypropos-last-regexp nil))
|
|
|
256
|
|
|
257 (defun hypropos-grok-functions (fns)
|
|
|
258 (let (fn bind type)
|
|
|
259 (while (setq fn (car fns))
|
|
|
260 (setq bind (symbol-function fn)
|
|
|
261 type (cond ((subrp bind) ?i)
|
|
|
262 ((compiled-function-p bind) ?b)
|
|
|
263 ((consp bind) (or (cdr
|
|
|
264 (assq (car bind) '((autoload . ?a)
|
|
|
265 (lambda . ?l)
|
|
|
266 (macro . ?m))))
|
|
|
267 ??))
|
|
|
268 (t ? )))
|
|
|
269 (insert type (if (commandp fn) "* " " "))
|
|
|
270 (insert-face (format "%-30S" fn) 'hyperlink)
|
|
|
271 (and hypropos-show-brief-docs
|
|
|
272 (if (function-obsolete-p fn)
|
|
|
273 (insert-face " - Obsolete." 'documentation)
|
|
|
274 (let ((doc (documentation fn)))
|
|
|
275 (if (not doc)
|
|
|
276 (insert-face " - Not documented." 'documentation)
|
|
|
277 (insert-face (concat " - "
|
|
|
278 (substring doc 0
|
|
|
279 (string-match "\n" doc)))
|
|
|
280 'documentation)))))
|
|
|
281 (insert ?\n)
|
|
|
282 (setq fns (cdr fns))
|
|
|
283 )))
|
|
|
284
|
|
|
285 (defun hypropos-grok-variables (vars)
|
|
|
286 (let (var userp)
|
|
|
287 (while (setq var (car vars))
|
|
|
288 (setq userp (user-variable-p var)
|
|
|
289 vars (cdr vars))
|
|
|
290 (insert (if userp " * " " "))
|
|
|
291 (insert-face (format "%-30S" var) 'hyperlink)
|
|
|
292 (and hypropos-show-brief-docs
|
|
|
293 (if (variable-obsolete-p var)
|
|
|
294 (insert-face " - Obsolete." 'documentation)
|
|
|
295 (let ((doc (documentation-property var 'variable-documentation)))
|
|
|
296 (if (not doc)
|
|
|
297 (insert-face " - Not documented." 'documentation)
|
|
|
298 (insert-face (concat " - "
|
|
|
299 (substring doc (if userp 1 0)
|
|
|
300 (string-match "\n" doc)))
|
|
|
301 'documentation)))))
|
|
|
302 (insert ?\n)
|
|
|
303 )))
|
|
|
304
|
|
|
305 ;; ---------------------------------------------------------------------- ;;
|
|
|
306
|
|
|
307 (defun hyper-apropos-mode (regexp)
|
|
|
308 "Improved apropos mode for displaying Emacs documentation. Function and
|
|
|
309 variable names are displayed in the buffer \"*Hyper Apropos*\".
|
|
|
310
|
|
|
311 Functions are preceded by a single character to indicates their types:
|
|
|
312 a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
|
|
|
313 Interactive functions are also preceded by an asterisk.
|
|
|
314 Variables are preceded by an asterisk if they are user variables.
|
|
|
315
|
|
|
316 General Commands:
|
|
|
317
|
|
|
318 SPC - scroll documentation or apropos window forward
|
|
|
319 b - scroll documentation or apropos window backward
|
|
|
320 k - eliminate all hits that don't contain keyword
|
|
|
321 n - new search
|
|
|
322 / - isearch-forward
|
|
|
323 q - quit and restore previous window configuration
|
|
|
324
|
|
|
325 Operations for Symbol on Current Line:
|
|
|
326
|
|
|
327 RET - toggle display of symbol's documentation
|
|
|
328 (also on button2 in xemacs)
|
|
|
329 w - show the keybinding if symbol is a command
|
|
|
330 i - invoke function on current line
|
|
|
331 s - set value of variable on current line
|
|
|
332 t - display the C or lisp source (find-tag)"
|
|
|
333 (delete-other-windows)
|
|
|
334 (setq mode-name "Hyper-Apropos"
|
|
|
335 major-mode 'hyper-apropos-mode
|
|
|
336 buffer-read-only t
|
|
|
337 truncate-lines t
|
|
|
338 hypropos-last-regexp regexp
|
|
|
339 modeline-buffer-identification (concat "Hyper Apropos: "
|
|
|
340 "\"" regexp "\""))
|
|
|
341 (setq mode-motion-hook 'mode-motion-highlight-line)
|
|
|
342 (use-local-map hypropos-map)
|
|
|
343 (run-hooks 'hyper-apropos-mode-hook))
|
|
|
344
|
|
|
345 ;; ---------------------------------------------------------------------- ;;
|
|
|
346
|
|
|
347 ;;;###autoload
|
|
|
348 (defun hyper-describe-variable (symbol)
|
|
|
349 "Hypertext drop-in replacement for `describe-variable'.
|
|
|
350 See also `hyper-apropos' and `hyper-describe-function'."
|
|
|
351 ;; #### - perhaps a prefix arg should suppress the prompt...
|
|
|
352 (interactive
|
|
|
353 (let* ((v (variable-at-point))
|
|
|
354 (val (let ((enable-recursive-minibuffers t))
|
|
|
355 (completing-read
|
|
|
356 (if v
|
|
|
357 (format "Describe variable (default %s): " v)
|
|
|
358 "Describe variable: ")
|
|
|
359 obarray 'boundp t))))
|
|
|
360 (list (if (string= val "") v (intern-soft val)))))
|
|
|
361 (if (null symbol)
|
|
|
362 (message "Sorry, nothing to describe.")
|
|
|
363 (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
|
|
|
364 (setq hypropos-prev-wconfig (current-window-configuration)))
|
|
|
365 (hypropos-get-doc symbol t)))
|
|
|
366
|
|
|
367 ;;;###autoload
|
|
|
368 (defun hyper-describe-function (symbol)
|
|
|
369 "Hypertext replacement for `describe-function'. Unlike `describe-function'
|
|
|
370 in that the symbol under the cursor is the default if it is a function.
|
|
|
371 See also `hyper-apropos' and `hyper-describe-variable'."
|
|
|
372 ;; #### - perhaps a prefix arg should suppress the prompt...
|
|
|
373 (interactive
|
|
|
374 (let (fn val)
|
|
|
375 (setq fn (hypropos-this-symbol)) ; symbol under point
|
|
|
376 (or (fboundp fn)
|
|
|
377 (setq fn (function-called-at-point)))
|
|
|
378 (setq val (let ((enable-recursive-minibuffers t))
|
|
|
379 (completing-read
|
|
|
380 (if fn
|
|
|
381 (format "Describe function (default %s): " fn)
|
|
|
382 "Describe function: ")
|
|
|
383 obarray 'fboundp t)))
|
|
|
384 (list (if (equal val "") fn (intern-soft val)))))
|
|
|
385 (if (null symbol)
|
|
|
386 (message "Sorry, nothing to describe.")
|
|
|
387 (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
|
|
|
388 (setq hypropos-prev-wconfig (current-window-configuration)))
|
|
|
389 (hypropos-get-doc symbol t)))
|
|
|
390
|
|
|
391 (defun hypropos-last-help (arg)
|
|
|
392 "Go back to the last symbol documented in the *Hyper Help* buffer."
|
|
|
393 (interactive "P")
|
|
|
394 (let ((win (get-buffer-window hypropos-help-buf))
|
|
|
395 (n (prefix-numeric-value arg)))
|
|
|
396 (cond ((and (not win) (not arg))
|
|
|
397 ;; don't alter the help-history, just redisplay
|
|
|
398 )
|
|
|
399 ((<= (length hypropos-help-history) n)
|
|
|
400 ;; go back as far as we can...
|
|
|
401 (setcdr (nreverse hypropos-help-history) nil))
|
|
|
402 (t
|
|
|
403 (setq hypropos-help-history (nthcdr n hypropos-help-history))))
|
|
|
404 (hypropos-get-doc (car hypropos-help-history) t)))
|
|
|
405
|
|
|
406 (defun hypropos-get-doc (&optional symbol force type)
|
|
|
407 ;; #### - update this docstring
|
|
|
408 "Toggle display of documentation for the symbol on the current line."
|
|
|
409 ;; SYMBOL is the symbol to document. FORCE, if non-nil, means to
|
|
|
410 ;; regenerate the documentation even if it already seems to be there. And
|
|
|
411 ;; TYPE, if present, forces the generation of only variable documentation
|
|
|
412 ;; or only function documentation. Normally, if both are present, then
|
|
|
413 ;; both will be generated.
|
|
|
414 ;;
|
|
|
415 ;; TYPES TO IMPLEMENT: obsolete face
|
|
|
416 ;;
|
|
|
417 (interactive)
|
|
|
418 (or symbol
|
|
|
419 (setq symbol (hypropos-this-symbol)))
|
|
|
420 (or type
|
|
|
421 (setq type '(function variable face)))
|
|
|
422 (if (and (eq hypropos-currently-showing symbol)
|
|
|
423 (get-buffer hypropos-help-buf)
|
|
|
424 (get-buffer-window hypropos-help-buf)
|
|
|
425 (not force))
|
|
|
426 ;; we're already displaying this help, so toggle its display.
|
|
|
427 (delete-windows-on hypropos-help-buf)
|
|
|
428 ;; OK, we've got to refresh and display it...
|
|
|
429 (or (eq symbol (car hypropos-help-history))
|
|
|
430 (setq hypropos-help-history
|
|
|
431 (if (eq major-mode 'hyper-help-mode)
|
|
|
432 ;; if we're following a link in the help buffer, then
|
|
|
433 ;; record that in the help history.
|
|
|
434 (cons symbol hypropos-help-history)
|
|
|
435 ;; otherwise clear the history because it's a new search.
|
|
|
436 (list symbol))))
|
|
|
437 (save-excursion
|
|
|
438 (set-buffer (get-buffer-create hypropos-help-buf))
|
|
|
439 (setq buffer-read-only nil)
|
|
|
440 (erase-buffer)
|
|
|
441 (let ((standard-output (current-buffer))
|
|
|
442 ok beg desc
|
|
|
443 ftype macrop fndef
|
|
|
444 keys val doc
|
|
|
445 obsolete aliases alias-desc)
|
|
|
446 (insert-face (format "`%s'\n\n" symbol) 'major-heading)
|
|
|
447 (and (memq 'function type)
|
|
|
448 (fboundp symbol)
|
|
|
449 (progn
|
|
|
450 (setq ok t
|
|
|
451 fndef (symbol-function symbol))
|
|
|
452 (while (symbolp fndef)
|
|
|
453 (setq aliases (cons fndef aliases))
|
|
|
454 (setq fndef (symbol-function fndef)))
|
|
|
455 (if (eq 'macro (car-safe fndef))
|
|
|
456 (setq macrop t
|
|
|
457 fndef (cdr fndef)))
|
|
|
458 (setq aliases (nreverse aliases))
|
|
|
459 ;; #### - the gods of internationalization shall strike me down!
|
|
|
460 (while aliases
|
|
|
461 (if alias-desc
|
|
|
462 (setq alias-desc (concat alias-desc ",\nwhich is ")))
|
|
|
463 (setq alias-desc (concat alias-desc
|
|
|
464 (format "an alias for `%s'"
|
|
|
465 (car aliases))))
|
|
|
466 (setq aliases (cdr aliases)))
|
|
|
467 (setq ftype (cond ((subrp fndef) 'subr)
|
|
|
468 ((compiled-function-p fndef) 'bytecode)
|
|
|
469 ((eq (car-safe fndef) 'autoload) 'autoload)
|
|
|
470 ((eq (car-safe fndef) 'lambda) 'lambda))
|
|
|
471 desc (concat (if (commandp symbol) "interactive ")
|
|
|
472 (cdr (assq ftype
|
|
|
473 '((subr . "built-in ")
|
|
|
474 (bytecode . "compiled Lisp ")
|
|
|
475 (autoload . "autoloaded Lisp ")
|
|
|
476 (lambda . "Lisp "))))
|
|
|
477 (if macrop "macro" "function")
|
|
|
478 ))
|
|
|
479 (if alias-desc
|
|
|
480 (setq desc (concat alias-desc
|
|
|
481 (if (memq (aref desc 0)
|
|
|
482 '(?a ?e ?i ?o ?u))
|
|
|
483 ", an " ", a ")
|
|
|
484 desc)))
|
|
|
485 (aset desc 0 (upcase (aref desc 0))) ; capitalize
|
|
|
486 (insert-face desc 'section-heading)
|
|
|
487 (and (eq ftype 'autoload)
|
|
|
488 (insert (format ", (autoloaded from \"%s\")"
|
|
|
489 (nth 1 fndef))))
|
|
|
490 ;; #### - should also show local binding in some other
|
|
|
491 ;; buffer so that this function can be used in place of
|
|
|
492 ;; describe-function and describe-variable.
|
|
|
493 (if (setq keys (where-is-internal symbol (current-global-map)
|
|
|
494 nil nil nil))
|
|
|
495 (insert (format ", (globally bound to %s)"
|
|
|
496 (mapconcat
|
|
|
497 #'(lambda (x)
|
|
|
498 (format "\"%s\""
|
|
|
499 (key-description x)))
|
|
|
500 (sort keys #'(lambda (x y)
|
|
|
501 (< (length x) (length y))))
|
|
|
502 ", "))))
|
|
|
503 (insert ":\n\n")
|
|
|
504 (setq beg (point)
|
|
|
505 doc (or (documentation symbol) "function not documented"))
|
|
|
506 (insert-face "arguments: " 'heading)
|
|
|
507 (cond ((eq ftype 'lambda)
|
|
|
508 (princ (or (nth 1 fndef) "()")))
|
|
|
509 ((eq ftype 'bytecode)
|
|
|
510 (princ (or (if (fboundp 'compiled-function-arglist)
|
|
|
511 (compiled-function-arglist fndef)
|
|
|
512 (aref fndef 0)) "()")))
|
|
|
513 ((and (eq ftype 'subr)
|
|
|
514 (string-match
|
|
|
515 "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
|
|
|
516 doc))
|
|
|
517 (insert (substring doc
|
|
|
518 (match-beginning 1)
|
|
|
519 (match-end 1)))
|
|
|
520 (setq doc (substring doc 0 (match-beginning 0))))
|
|
|
521 (t (princ "[not available]")))
|
|
|
522 (insert "\n\n")
|
|
|
523 (let ((new
|
|
|
524 ;; cookbook from bytecomp.el
|
|
|
525 (get symbol 'byte-obsolete-info)))
|
|
|
526 (and new
|
|
|
527 (insert-face
|
|
|
528 (format "%s is an obsolete function; %s\n\n" symbol
|
|
|
529 (if (stringp (car new))
|
|
|
530 (car new)
|
|
|
531 (format "use %s instead." (car new))))
|
|
|
532 'warning)))
|
|
|
533 (insert-face doc 'documentation)
|
|
|
534 (indent-rigidly beg (point) 1)
|
|
|
535 (insert"\n\n")
|
|
|
536 ))
|
|
|
537 (and (memq 'variable type)
|
|
|
538 (boundp symbol)
|
|
|
539 (progn
|
|
|
540 (setq ok t)
|
|
|
541 (insert-face (if (user-variable-p symbol)
|
|
|
542 "User variable"
|
|
|
543 "Variable")
|
|
|
544 'section-heading)
|
|
|
545 (and (local-variable-p symbol nil t)
|
|
|
546 (insert ", local when set"))
|
|
|
547 (insert ":\n\n")
|
|
|
548 (setq beg (point)
|
|
|
549 val (prin1-to-string (symbol-value symbol))
|
|
|
550 doc (or (documentation-property
|
|
|
551 symbol 'variable-documentation)
|
|
|
552 "variable not documented"))
|
|
|
553
|
|
|
554 (let ((ob (get symbol 'byte-obsolete-variable)))
|
|
|
555 (setq obsolete
|
|
|
556 (and ob (format "%s is an obsolete variable; %s\n\n"
|
|
|
557 symbol
|
|
|
558 (if (stringp ob)
|
|
|
559 ob
|
|
|
560 (format "use %s instead." ob))))))
|
|
|
561 ;; generally, the value of the variable is short and the
|
|
|
562 ;; documentation of the variable long, so it's desirable
|
|
|
563 ;; to see all of the value and the start of the
|
|
|
564 ;; documentation. Some variables, though, have huge and
|
|
|
565 ;; nearly meaningless values that force you to page
|
|
|
566 ;; forward just to find the doc string. That is
|
|
|
567 ;; undesirable.
|
|
|
568 (if (< (length val) 69) ; 80 cols. docstrings assume this.
|
|
|
569 (progn (insert-face "value: " 'heading)
|
|
|
570 (insert (format "%s\n\n" val))
|
|
|
571 (and obsolete (insert-face obsolete 'warning))
|
|
|
572 (insert-face doc 'documentation))
|
|
|
573 (insert "(see below for value)\n\n")
|
|
|
574 (and obsolete (insert-face obsolete 'warning))
|
|
|
575 (insert-face doc 'documentation)
|
|
|
576 (insert "\n\n")
|
|
|
577 (insert-face "value: " 'heading)
|
|
|
578 (if hypropos-prettyprint-long-values
|
|
|
579 (let ((pp-print-readably nil))
|
|
|
580 (pprint (symbol-value symbol)))
|
|
|
581 (insert val)))
|
|
|
582 (indent-rigidly beg (point) 2)
|
|
|
583 ))
|
|
|
584 (and (memq 'face type)
|
|
|
585 (find-face symbol)
|
|
|
586 (progn
|
|
|
587 (setq ok t)
|
|
|
588 ;; #### - add some code here
|
|
|
589 (insert "Face documentation is \"To be implemented.\"\n\n")
|
|
|
590 )
|
|
|
591 )
|
|
|
592 (or ok (insert-face "symbol is not currently bound" 'heading)))
|
|
|
593 (goto-char (point-min))
|
|
|
594 ;; pop up window and shrink it if it's wasting space
|
|
|
595 (shrink-window-if-larger-than-buffer
|
|
|
596 (display-buffer (current-buffer)))
|
|
|
597 (hyper-help-mode)) )
|
|
|
598 (setq hypropos-currently-showing symbol))
|
|
|
599
|
|
|
600 ; -----------------------------------------------------------------------------
|
|
|
601
|
|
|
602 (defun hyper-help-mode ()
|
|
|
603 "Major mode for hypertext XEmacs help. In this mode, you can quickly
|
|
|
604 follow links between back and forth between the documentation strings for
|
|
|
605 different variables and functions. Common commands:
|
|
|
606
|
|
|
607 \\{hypropos-help-map}"
|
|
|
608 (setq mode-motion-hook 'hypropos-highlight-lisp-symbol
|
|
|
609 buffer-read-only t
|
|
|
610 major-mode 'hyper-help-mode
|
|
|
611 mode-name "Hyper-Help")
|
|
|
612 (set-syntax-table emacs-lisp-mode-syntax-table)
|
|
|
613 (use-local-map hypropos-help-map))
|
|
|
614
|
|
|
615 (defun hypropos-highlight-lisp-symbol (event)
|
|
|
616 ;; mostly copied from mode-motion-highlight-internal
|
|
|
617 (let* ((window (event-window event))
|
|
|
618 (buffer (and window (window-buffer window)))
|
|
|
619 (point (and buffer (event-point event)))
|
|
|
620 st en sym highlight-p)
|
|
|
621 (if buffer
|
|
|
622 (progn
|
|
|
623 (set-buffer buffer)
|
|
|
624 (if point
|
|
|
625 (save-excursion
|
|
|
626 (goto-char point)
|
|
|
627 (setq st (save-excursion
|
|
|
628 (skip-syntax-backward "w_")
|
|
|
629 (skip-chars-forward "`")
|
|
|
630 (point))
|
|
|
631 en (save-excursion
|
|
|
632 (goto-char st)
|
|
|
633 (skip-syntax-forward "w_")
|
|
|
634 (skip-chars-backward ".")
|
|
|
635 (point))
|
|
|
636 sym (and (not (eq st en))
|
|
|
637 (intern-soft (buffer-substring st en)))
|
|
|
638 highlight-p (and sym
|
|
|
639 (or (boundp sym)
|
|
|
640 (fboundp sym))))
|
|
|
641 (if highlight-p
|
|
|
642 (if mode-motion-extent
|
|
|
643 (set-extent-endpoints mode-motion-extent st en)
|
|
|
644 (setq mode-motion-extent (make-extent st en))
|
|
|
645 (set-extent-property mode-motion-extent 'highlight t))
|
|
|
646 (and mode-motion-extent
|
|
|
647 (progn (delete-extent mode-motion-extent)
|
|
|
648 (setq mode-motion-extent nil)))
|
|
|
649 ))
|
|
|
650 ;; not over text; zero the extent.
|
|
|
651 (if (and mode-motion-extent (extent-buffer mode-motion-extent)
|
|
|
652 (not (eq (extent-start-position mode-motion-extent)
|
|
|
653 (extent-end-position mode-motion-extent))))
|
|
|
654 (set-extent-endpoints mode-motion-extent 1 1)))))))
|
|
|
655
|
|
|
656
|
|
|
657 ;; ---------------------------------------------------------------------- ;;
|
|
|
658
|
|
|
659 (defun hypropos-scroll-up ()
|
|
|
660 "Scroll up the \"*Hyper Help*\" buffer if it's visible, or scroll this window up."
|
|
|
661 (interactive)
|
|
|
662 (let ((win (get-buffer-window hypropos-help-buf))
|
|
|
663 (owin (selected-window)))
|
|
|
664 (if win
|
|
|
665 (progn
|
|
|
666 (select-window win)
|
|
|
667 (condition-case nil
|
|
|
668 (scroll-up nil)
|
|
|
669 (error (goto-char (point-max))))
|
|
|
670 (select-window owin))
|
|
|
671 (scroll-up nil))))
|
|
|
672
|
|
|
673 (defun hypropos-scroll-down ()
|
|
|
674 "Scroll down the \"*Hyper Help*\" buffer if it's visible, or scroll this window down."
|
|
|
675 (interactive)
|
|
|
676 (let ((win (get-buffer-window hypropos-help-buf))
|
|
|
677 (owin (selected-window)))
|
|
|
678 (if win
|
|
|
679 (progn
|
|
|
680 (select-window win)
|
|
|
681 (condition-case nil
|
|
|
682 (scroll-down nil)
|
|
|
683 (error (goto-char (point-max))))
|
|
|
684 (select-window owin))
|
|
|
685 (scroll-down nil))))
|
|
|
686
|
|
|
687 ;; ---------------------------------------------------------------------- ;;
|
|
|
688
|
|
|
689 (defun hypropos-mouse-get-doc (event)
|
|
|
690 "Get the documentation for the symbol the mouse is on."
|
|
|
691 (interactive "e")
|
|
|
692 (mouse-set-point event)
|
|
|
693 (save-excursion
|
|
|
694 (let ((symbol (hypropos-this-symbol)))
|
|
|
695 (if symbol
|
|
|
696 (hypropos-get-doc symbol)
|
|
|
697 (error "Click on a symbol")))))
|
|
|
698
|
|
|
699 ;; ---------------------------------------------------------------------- ;;
|
|
|
700
|
|
|
701 (defun hypropos-add-keyword (pattern)
|
|
|
702 "Use additional keyword to narrow regexp match.
|
|
|
703 Deletes lines which don't match PATTERN."
|
|
|
704 (interactive "sAdditional Keyword: ")
|
|
|
705 (save-excursion
|
|
|
706 (goto-char (point-min))
|
|
|
707 (let (buffer-read-only)
|
|
|
708 (keep-lines (concat pattern "\\|" hypropos-junk-regexp))
|
|
|
709 )))
|
|
|
710
|
|
|
711 (defun hypropos-eliminate-keyword (pattern)
|
|
|
712 "Use additional keyword to eliminate uninteresting matches.
|
|
|
713 Deletes lines which match PATTERN."
|
|
|
714 (interactive "sKeyword to eliminate: ")
|
|
|
715 (save-excursion
|
|
|
716 (goto-char (point-min))
|
|
|
717 (let (buffer-read-only)
|
|
|
718 (flush-lines pattern))
|
|
|
719 ))
|
|
|
720
|
|
|
721 ;; ---------------------------------------------------------------------- ;;
|
|
|
722
|
|
|
723 (defun hypropos-this-symbol ()
|
|
|
724 (save-excursion
|
|
|
725 (cond ((eq major-mode 'hyper-apropos-mode)
|
|
|
726 (beginning-of-line)
|
|
|
727 (if (looking-at hypropos-junk-regexp)
|
|
|
728 nil
|
|
|
729 (forward-char 3)
|
|
|
730 (read (point-marker))))
|
|
|
731 (t
|
|
|
732 (let* ((st (progn
|
|
|
733 (skip-syntax-backward "w_")
|
|
|
734 ;; !@(*$^%%# stupid backquote implementation!!!
|
|
|
735 (skip-chars-forward "`")
|
|
|
736 (point)))
|
|
|
737 (en (progn
|
|
|
738 (skip-syntax-forward "w_")
|
|
|
739 (skip-chars-backward ".")
|
|
|
740 (point))))
|
|
|
741 (and (not (eq st en))
|
|
|
742 (intern-soft (buffer-substring st en))))))))
|
|
|
743
|
|
|
744 (defun hypropos-where-is (symbol)
|
|
|
745 "Find keybinding for symbol on current line."
|
|
|
746 (interactive (list (hypropos-this-symbol)))
|
|
|
747 (where-is symbol))
|
|
|
748
|
|
|
749 (defun hypropos-invoke-fn (fn)
|
|
|
750 "Interactively invoke the function on the current line."
|
|
|
751 (interactive (list (hypropos-this-symbol)))
|
|
|
752 (cond ((not (fboundp fn))
|
|
|
753 (error "%S is not a function" fn))
|
|
|
754 (t (call-interactively fn))))
|
|
|
755
|
|
|
756 ;;;###autoload
|
|
|
757 (defun hypropos-set-variable (var val)
|
|
|
758 "Interactively set the variable on the current line."
|
|
|
759 (interactive
|
|
|
760 (let ((var (save-excursion
|
|
|
761 (and (eq major-mode 'hypropos-help-mode)
|
|
|
762 (goto-char (point-min)))
|
|
|
763 (hypropos-this-symbol))))
|
|
|
764 (or (boundp var)
|
|
|
765 (setq var (completing-read "Set variable: "
|
|
|
766 obarray 'boundp t)))
|
|
|
767 (hypropos-get-doc var t)
|
|
|
768 (list var
|
|
|
769 (let ((prop (get var 'variable-interactive))
|
|
|
770 (print-readably t)
|
|
|
771 (val (symbol-value var)))
|
|
|
772 (if prop
|
|
|
773 (call-interactively (list 'lambda '(arg)
|
|
|
774 (list 'interactive prop)
|
|
|
775 'arg))
|
|
|
776 (eval-minibuffer
|
|
|
777 (format "Set `%s' to value (evaluated): " var)
|
|
|
778 (format (if (or (consp val)
|
|
|
779 (and (symbolp val)
|
|
|
780 (not (memq val '(t nil)))))
|
|
|
781 "'%s" "%s")
|
|
|
782 (prin1-to-string val))))))
|
|
|
783 ))
|
|
|
784 (set var val)
|
|
|
785 (hypropos-get-doc var t))
|
|
|
786
|
|
|
787 ;; ---------------------------------------------------------------------- ;;
|
|
|
788
|
|
|
789 (defun hypropos-find-tag (&optional tag-name)
|
|
|
790 "Find the tag for the symbol on the current line in other window. In
|
|
|
791 order for this to work properly, the variable `tag-table-alist' or
|
|
|
792 `tags-file-name' must be set so that a TAGS file with tags for the emacs
|
|
|
793 source is found for the \"*Hyper Apropos*\" buffer."
|
|
|
794 (interactive)
|
|
|
795 ;; there ought to be a default tags file for this...
|
|
|
796 (or tag-name (setq tag-name (symbol-name (hypropos-this-symbol))))
|
|
|
797 (find-tag-other-window (list tag-name)))
|
|
|
798
|
|
|
799 ;; ---------------------------------------------------------------------- ;;
|
|
|
800
|
|
|
801 (defun hypropos-disassemble (sym)
|
|
|
802 "Disassemble FUN if it is byte-coded. If it's a lambda, prettyprint it."
|
|
|
803 (interactive (list (hypropos-this-symbol)))
|
|
|
804 (let ((fun sym) (trail nil) macrop)
|
|
|
805 (while (and (symbolp fun) (not (memq fun trail)))
|
|
|
806 (setq trail (cons fun trail)
|
|
|
807 fun (symbol-function fun)))
|
|
|
808 (and (symbolp fun)
|
|
|
809 (error "Loop detected in function binding of `%s'" fun))
|
|
|
810 (setq macrop (and (consp fun)
|
|
|
811 (eq 'macro (car fun))))
|
|
|
812 (cond ((compiled-function-p (if macrop (cdr fun) fun))
|
|
|
813 (disassemble fun)
|
|
|
814 (set-buffer "*Disassemble*")
|
|
|
815 (goto-char (point-min))
|
|
|
816 (forward-sexp 2)
|
|
|
817 (insert (format " for function `%S'" sym))
|
|
|
818 )
|
|
|
819 ((consp fun)
|
|
|
820 (with-output-to-temp-buffer "*Disassemble*"
|
|
|
821 (pprint (if macrop
|
|
|
822 (cons 'defmacro (cons sym (cdr (cdr fun))))
|
|
|
823 (cons 'defun (cons sym (cdr fun))))))
|
|
|
824 (set-buffer "*Disassemble*")
|
|
|
825 (emacs-lisp-mode))
|
|
|
826 ((or (vectorp fun) (stringp fun))
|
|
|
827 ;; #### - do something fancy here
|
|
|
828 (with-output-to-temp-buffer "*Disassemble*"
|
|
|
829 (princ (format "%s is a keyboard macro:\n\n\t" sym))
|
|
|
830 (prin1 fun)))
|
|
|
831 (t
|
|
|
832 (error "Sorry, cannot disassemble `%s'" sym)))))
|
|
|
833
|
|
|
834 ;; ---------------------------------------------------------------------- ;;
|
|
|
835
|
|
|
836 (defun hypropos-quit ()
|
|
|
837 (interactive)
|
|
|
838 "Quit Hyper Apropos and restore original window config."
|
|
|
839 (let ((buf (get-buffer hypropos-apropos-buf)))
|
|
|
840 (and buf (bury-buffer buf)))
|
|
|
841 (set-window-configuration hypropos-prev-wconfig))
|
|
|
842
|
|
|
843 ;; ---------------------------------------------------------------------- ;;
|
|
|
844
|
|
|
845 ;;;###autoload
|
|
|
846 (defun hypropos-popup-menu (event)
|
|
|
847 (interactive "e")
|
|
|
848 (mouse-set-point event)
|
|
|
849 (let* ((sym (hypropos-this-symbol))
|
|
|
850 (notjunk (not (null sym)))
|
|
|
851 (command-p (commandp sym))
|
|
|
852 (variable-p (and sym (boundp sym)))
|
|
|
853 (function-p (fboundp sym))
|
|
|
854 (apropos-p (eq 'hyper-apropos-mode
|
|
|
855 (save-excursion (set-buffer (event-buffer event))
|
|
|
856 major-mode)))
|
|
|
857 (name (if sym (symbol-name sym) ""))
|
|
|
858 (hypropos-menu
|
|
|
859 (delete
|
|
|
860 nil
|
|
|
861 (list (concat "Hyper-Help: " name)
|
|
|
862 (vector "Display documentation" 'hypropos-get-doc notjunk)
|
|
|
863 (vector "Set variable" 'hypropos-set-variable variable-p)
|
|
|
864 (vector "Show keys for" 'hypropos-where-is command-p)
|
|
|
865 (vector "Invoke command" 'hypropos-invoke-fn command-p)
|
|
|
866 (vector "Find tag" 'hypropos-find-tag notjunk)
|
|
|
867 (and apropos-p
|
|
|
868 ["Add keyword..." hypropos-add-keyword t])
|
|
|
869 (and apropos-p
|
|
|
870 ["Eliminate keyword..." hypropos-eliminate-keyword t])
|
|
|
871 (if apropos-p
|
|
|
872 ["Programmers' Apropos" hypropos-toggle-programming-flag
|
|
|
873 :style toggle :selected hypropos-programming-apropos]
|
|
|
874 ["Programmers' Help" hypropos-toggle-programming-flag
|
|
|
875 :style toggle :selected hypropos-programming-apropos])
|
|
|
876 (and hypropos-programming-apropos
|
|
|
877 (vector "Disassemble function"
|
|
|
878 'hypropos-disassemble
|
|
|
879 function-p))
|
|
|
880 ["Help" describe-mode t]
|
|
|
881 ["Quit" hypropos-quit t]
|
|
|
882 ))))
|
|
|
883 (popup-menu hypropos-menu)))
|
|
|
884
|
|
|
885 (provide 'hyper-apropos)
|
|
|
886
|
|
|
887 ;; end of hyper-apropos.el
|
|
|
888
|
