Mercurial > hg > xemacs-beta
comparison lisp/packages/hyper-apropos.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | 0293115a14e9 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 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 |