Mercurial > hg > xemacs-beta

comparison lisp/packages/hyper-apropos.el @ 161:28f395d8dc7a r20-3b7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b7
author cvs
date Mon, 13 Aug 2007 09:42:26 +0200
parents 43dd3413c7c7
children 0132846995bd
comparison
equal deleted inserted replaced
160:1c55655d6702 161:28f395d8dc7a
53 ;; 53 ;;
54 ;; additions by Ben Wing <wing@666.com> July 1995: 54 ;; additions by Ben Wing <wing@666.com> July 1995:
55 ;; added support for function aliases, made programmer's apropos be the 55 ;; added support for function aliases, made programmer's apropos be the
56 ;; default, various other hacking. 56 ;; default, various other hacking.
57 ;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de> 57 ;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de>
58 ;; Some changes for XEmacs 20.3 by hniksic
58 59
59 ;;; Code: 60 ;;; Code:
60 61
61 (or (fboundp 'pprint) 62 (require 'pp)
62 (progn (autoload 'pp "pp")
63 (fset 'pprint 'pp)))
64 ;;(require 'tags "etags")
65 63
66 (defgroup hyper-apropos nil 64 (defgroup hyper-apropos nil
67 "Hypertext emacs lisp documentation interface." 65 "Hypertext emacs lisp documentation interface."
68 :prefix "hypropos-" 66 :prefix "hypropos-"
69 :group 'docs) 67 :group 'docs
68 :group 'lisp
69 :group 'tools
70 :group 'help
71 :group 'matching)
70 72
71 ;;;###autoload 73 ;;;###autoload
72 (defcustom hypropos-show-brief-docs t 74 (defcustom hypropos-show-brief-docs t
73 "*If non-nil, `hyper-apropos' will display some documentation in the 75 "*If non-nil, `hyper-apropos' will display some documentation in the
74 \"*Hyper Apropos*\" buffer. Setting this to nil will speed up searches." 76 \"*Hyper Apropos*\" buffer. Setting this to nil will speed up searches."
75 :type 'boolean 77 :type 'boolean
76 :group 'hyper-apropos) 78 :group 'hyper-apropos)
77 79
78 (defcustom hypropos-shrink-window nil
79 "*If non-nil, shrink *Hyper Help* buffer if possible."
80 :type 'boolean
81 :group 'hyper-apropos)
82
83 (defcustom hypropos-prettyprint-long-values t
84 "*If non-nil, then try to beautify the printing of very long values."
85 :type 'boolean
86 :group 'hyper-apropos)
87
88 ;; I changed this to true because I think it's more useful this way. --ben 80 ;; I changed this to true because I think it's more useful this way. --ben
89 81
90 (defcustom hypropos-programming-apropos t 82 (defcustom hypropos-programming-apropos t
91 "*If non-nil, then `hyper-apropos' takes a bit longer and generates more 83 "*If non-nil, then `hyper-apropos' takes a bit longer and generates more
92 output. If nil, then only functions that are interactive and variables that 84 output. If nil, then only functions that are interactive and variables that
93 are user variables are found by `hyper-apropos'." 85 are user variables are found by `hyper-apropos'."
94 :type 'boolean 86 :type 'boolean
95 :group 'hyper-apropos) 87 :group 'hyper-apropos)
96 88
89 (defcustom hypropos-shrink-window nil
90 "*If non-nil, shrink *Hyper Help* buffer if possible."
91 :type 'boolean
92 :group 'hyper-apropos)
93
94 (defcustom hypropos-prettyprint-long-values t
95 "*If non-nil, then try to beautify the printing of very long values."
96 :type 'boolean
97 :group 'hyper-apropos)
98
99
100 (defgroup hypropos-faces nil
101 "Faces defined by hyper-apropos."
102 :prefix "hypropos-"
103 :group 'hyper-apropos)
104
105
106 (defface hypropos-documentation '((((class color) (background light))
107 (:foreground "darkred"))
108 (((class color) (background dark))
109 (:foreground "gray90")))
110 "Hyper-apropos documentation."
111 :group 'hypropos-faces)
112
113 (defface hypropos-hyperlink '((((class color) (background light))
114 (:foreground "blue4"))
115 (((class color) (background dark))
116 (:foreground "lightseagreen"))
117 (t
118 (:bold t)))
119 "Hyper-apropos hyperlinks."
120 :group 'hypropos-faces)
121
122 (defface hypropos-major-heading '((t (:bold t)))
123 "Hyper-apropos major heading."
124 :group 'hypropos-faces)
125
126 (defface hypropos-section-heading '((t (:bold t :italic t)))
127 "Hyper-apropos section heading."
128 :group 'hypropos-faces)
129
130 (defface hypropos-heading '((t (:bold t)))
131 "Hyper-apropos heading."
132 :group 'hypropos-faces)
133
134 (defface hypropos-warning '((t (:bold t :foreground "red")))
135 "Hyper-apropos warning."
136 :group 'hypropos-faces)
137
138
139 ;;; Internal variables below this point
140
97 (defvar hypropos-ref-buffer) 141 (defvar hypropos-ref-buffer)
98 (defvar hypropos-prev-wconfig) 142 (defvar hypropos-prev-wconfig)
99 143
100 ;; #### - move this to subr.el 144 (defvar hypropos-help-map
101 (or (fboundp 'event-buffer) 145 (let ((map (make-sparse-keymap)))
102 (defun event-buffer (event) 146 (suppress-keymap map)
103 "Returns the buffer associated with event, or nil." 147 (set-keymap-name map 'hypropos-help-map)
104 (let ((win (event-window event))) 148 ;; movement
105 (and win (window-buffer win))))) 149 (define-key map " " 'scroll-up)
106 150 (define-key map "b" 'scroll-down)
107 (defmacro eval-in-buffer (buffer &rest forms) 151 (define-key map [delete] 'scroll-down)
108 "Evaluate FORMS in BUFFER." 152 (define-key map [backspace] 'scroll-down)
109 (` (let ((_unwind_buf_ (current-buffer))) 153 (define-key map "/" 'isearch-forward)
110 (unwind-protect 154 (define-key map "?" 'isearch-backward)
111 (progn (set-buffer (, buffer)) 155 ;; follow links
112 (,@ forms)) 156 (define-key map [return] 'hypropos-get-doc)
113 (set-buffer _unwind_buf_))))) 157 (define-key map "s" 'hypropos-set-variable)
114 (put 'eval-in-buffer 'lisp-indent-function 'defun) 158 (define-key map "t" 'hypropos-find-tag)
115 159 (define-key map "l" 'hypropos-last-help)
116 ;; #### - move to faces.el 160 (define-key map "c" 'hypropos-customize-variable)
117 (defmacro init-face (face &rest init-forms) 161 (define-key map [button2] 'hypropos-mouse-get-doc)
118 "Make a FACE if it doesn't already exist. Then if it does not differ from 162 (define-key map [button3] 'hypropos-popup-menu)
119 the default face, execute INIT-FORMS to initialize the face. While the 163 ;; for the totally hardcore...
120 init-forms are executing, the symbol `this' is bound to the face-object 164 (define-key map "D" 'hypropos-disassemble)
121 being initialized." 165 ;; administrativa
122 (` (let ((this (make-face (, face)))) ; harmless if the face is already there 166 (define-key map "a" 'hyper-apropos)
123 (or (face-differs-from-default-p this) 167 (define-key map "n" 'hyper-apropos)
124 (, (cons 'progn init-forms)))))) 168 (define-key map "q" 'hypropos-quit)
125 (put 'init-face 'lisp-indent-function 'defun) 169 map)
126
127 (init-face 'hyperlink
128 (copy-face 'bold this)
129 ;;(set-face-underline-p this nil) -- dog slow and ugly
130 (condition-case nil
131 (set-face-foreground this "blue")
132 (error nil)))
133 (init-face 'documentation
134 (let* ((ff-instance (face-font-instance 'default))
135 (ff (and ff-instance (font-instance-name ff-instance))))
136 (cond ((and ff (string-match "courier" ff))
137 ;; too wide unless you shrink it
138 ;; (copy-face 'italic this) fugly.
139 ;; (make-face-smaller this) fugly.
140 ))
141 (condition-case nil
142 (set-face-foreground this "firebrick")
143 (error (copy-face 'italic this)))))
144
145 ;; mucking with the sizes of fonts (perhaps with the exception of courier or
146 ;; misc) is a generally losing thing to do. Changing the size of 'clean'
147 ;; really loses, for instance...
148
149 (init-face 'major-heading
150 (copy-face 'bold this)
151 (make-face-larger this)
152 (make-face-larger this))
153 (init-face 'section-heading
154 (copy-face 'bold this)
155 (make-face-larger this))
156 (init-face 'heading
157 (copy-face 'bold this))
158 (init-face 'standout
159 (copy-face 'italic this))
160
161 (init-face 'warning
162 (copy-face 'bold this)
163 (and (eq (device-type) 'x)
164 (eq (device-class) 'color)
165 (set-face-foreground this "red")))
166
167 (defvar hypropos-help-map (let ((map (make-sparse-keymap)))
168 (suppress-keymap map)
169 (set-keymap-name map 'hypropos-help-map)
170 ;; movement
171 (define-key map " " 'scroll-up)
172 (define-key map "b" 'scroll-down)
173 (define-key map [delete] 'scroll-down)
174 (define-key map [backspace] 'scroll-down)
175 (define-key map "/" 'isearch-forward)
176 (define-key map "?" 'isearch-backward)
177 ;; follow links
178 (define-key map "\r" 'hypropos-get-doc)
179 (define-key map "s" 'hypropos-set-variable)
180 (define-key map "t" 'hypropos-find-tag)
181 (define-key map "l" 'hypropos-last-help)
182 (define-key map [button2] 'hypropos-mouse-get-doc)
183 (define-key map [button3] 'hypropos-popup-menu)
184 ;; for the totally hardcore...
185 (define-key map "D" 'hypropos-disassemble)
186 ;; administrativa
187 (define-key map "a" 'hyper-apropos)
188 (define-key map "n" 'hyper-apropos)
189 (define-key map "q" 'hypropos-quit)
190 map
191 )
192 "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer") 170 "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer")
193 171
194 (defvar hypropos-map (let ((map (make-sparse-keymap))) 172 (defvar hypropos-map
195 (set-keymap-name map 'hypropos-map) 173 (let ((map (make-sparse-keymap)))
196 (set-keymap-parents map (list hypropos-help-map)) 174 (set-keymap-name map 'hypropos-map)
197 ;; slightly different scrolling... 175 (set-keymap-parents map (list hypropos-help-map))
198 (define-key map " " 'hypropos-scroll-up) 176 ;; slightly different scrolling...
199 (define-key map "b" 'hypropos-scroll-down) 177 (define-key map " " 'hypropos-scroll-up)
200 (define-key map [delete] 'hypropos-scroll-down) 178 (define-key map "b" 'hypropos-scroll-down)
201 (define-key map [backspace] 'hypropos-scroll-down) 179 (define-key map [delete] 'hypropos-scroll-down)
202 ;; act on the current line... 180 (define-key map [backspace] 'hypropos-scroll-down)
203 (define-key map "w" 'hypropos-where-is) 181 ;; act on the current line...
204 (define-key map "i" 'hypropos-invoke-fn) 182 (define-key map "w" 'hypropos-where-is)
205 (define-key map "s" 'hypropos-set-variable) 183 (define-key map "i" 'hypropos-invoke-fn)
206 ;; more administrativa... 184 (define-key map "s" 'hypropos-set-variable)
207 (define-key map "P" 'hypropos-toggle-programming-flag) 185 ;; more administrativa...
208 (define-key map "k" 'hypropos-add-keyword) 186 (define-key map "P" 'hypropos-toggle-programming-flag)
209 (define-key map "e" 'hypropos-eliminate-keyword) 187 (define-key map "k" 'hypropos-add-keyword)
210 map 188 (define-key map "e" 'hypropos-eliminate-keyword)
211 ) 189 map)
212 "Keybindings for the *Hyper Apropos* buffer. 190 "Keybindings for the *Hyper Apropos* buffer.
213 This map inherits from `hypropos-help-map.'") 191 This map inherits from `hypropos-help-map.'")
192
193 ;;(defvar hypropos-mousable-keymap
194 ;; (let ((map (make-sparse-keymap)))
195 ;; (define-key map [button2] 'hypropos-mouse-get-doc)
196 ;; map))
214 197
215 (defvar hyper-apropos-mode-hook nil 198 (defvar hyper-apropos-mode-hook nil
216 "*User function run after hyper-apropos mode initialization. Usage: 199 "*User function run after hyper-apropos mode initialization. Usage:
217 \(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).") 200 \(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).")
218 201
246 (if (get-buffer hypropos-apropos-buf) 229 (if (get-buffer hypropos-apropos-buf)
247 (if toggle-apropos 230 (if toggle-apropos
248 (hypropos-toggle-programming-flag) 231 (hypropos-toggle-programming-flag)
249 (message "Using last search results")) 232 (message "Using last search results"))
250 (error "Be more specific...")) 233 (error "Be more specific..."))
251 (let (flist vlist) 234 (set-buffer (get-buffer-create hypropos-apropos-buf))
252 (set-buffer (get-buffer-create hypropos-apropos-buf)) 235 (setq buffer-read-only nil)
253 (setq buffer-read-only nil) 236 (erase-buffer)
254 (erase-buffer) 237 (if toggle-apropos
255 (if toggle-apropos 238 (set (make-local-variable 'hypropos-programming-apropos)
256 (set (make-local-variable 'hypropos-programming-apropos) 239 (not (default-value 'hypropos-programming-apropos))))
257 (not (default-value 'hypropos-programming-apropos)))) 240 (let ((flist (apropos-internal regexp
258 (if (not hypropos-programming-apropos) 241 (if hypropos-programming-apropos
259 (setq flist (apropos-internal regexp 'commandp) 242 #'fboundp
260 vlist (apropos-internal regexp 'user-variable-p)) 243 #'commandp)))
261 ;; #### - add obsolete functions/variables here... 244 (vlist (apropos-internal regexp
262 ;; #### - 'variables' may be unbound !!! 245 (if hypropos-programming-apropos
263 (setq flist (apropos-internal regexp 'fboundp) 246 #'boundp
264 vlist (apropos-internal regexp 'boundp))) 247 #'user-variable-p))))
265 (insert-face (format "Apropos search for: %S\n\n" regexp) 'major-heading) 248 (insert-face (format "Apropos search for: %S\n\n" regexp)
266 (insert-face "* = command (M-x) or user-variable.\n" 'documentation) 249 'hypropos-major-heading)
267 (insert-face "a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n" 'documentation) 250 (insert-face "* = command (M-x) or user-variable.\n"
268 (insert-face "Functions and Macros:\n\n" 'major-heading) 251 'hypropos-documentation)
252 (insert-face "\
253 a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n"
254 'hypropos-documentation)
255 (insert-face "Functions and Macros:\n\n" 'hypropos-major-heading)
269 (hypropos-grok-functions flist) 256 (hypropos-grok-functions flist)
270 (insert-face "\n\nVariables and Constants:\n\n" 'major-heading) 257 (insert-face "\n\nVariables and Constants:\n\n" 'hypropos-major-heading)
271 (hypropos-grok-variables vlist) 258 (hypropos-grok-variables vlist)
272 (goto-char (point-min)) 259 (goto-char (point-min))))
273 ))
274 (switch-to-buffer hypropos-apropos-buf) 260 (switch-to-buffer hypropos-apropos-buf)
275 (hyper-apropos-mode regexp)) 261 (hyper-apropos-mode regexp))
276 262
277 (defun hypropos-toggle-programming-flag () 263 (defun hypropos-toggle-programming-flag ()
278 (interactive) 264 (interactive)
281 (not hypropos-programming-apropos))) 267 (not hypropos-programming-apropos)))
282 (message "Re-running apropos...") 268 (message "Re-running apropos...")
283 (hyper-apropos hypropos-last-regexp nil)) 269 (hyper-apropos hypropos-last-regexp nil))
284 270
285 (defun hypropos-grok-functions (fns) 271 (defun hypropos-grok-functions (fns)
286 (let (fn bind doc type) 272 (let (bind doc type)
287 (while (setq fn (car fns)) 273 (dolist (fn fns)
288 (setq bind (symbol-function fn) 274 (setq bind (symbol-function fn)
289 type (cond ((subrp bind) ?i) 275 type (cond ((subrp bind) ?i)
290 ((compiled-function-p bind) ?b) 276 ((compiled-function-p bind) ?b)
291 ((consp bind) (or (cdr 277 ((consp bind) (or (cdr
292 (assq (car bind) '((autoload . ?a) 278 (assq (car bind) '((autoload . ?a)
293 (lambda . ?l) 279 (lambda . ?l)
294 (macro . ?m)))) 280 (macro . ?m))))
295 ??)) 281 ??))
296 (t ? ))) 282 (t ?\ )))
297 (insert type (if (commandp fn) "* " " ")) 283 (insert type (if (commandp fn) "* " " "))
298 (insert-face (format "%-30S" fn) 'hyperlink) 284 (let ((e (insert-face (format "%S" fn) 'hypropos-hyperlink)))
285 (set-extent-property e 'mouse-face 'highlight))
286 (insert-char ?\ (let ((l (- 30 (length (format "%S" fn)))))
287 (if (natnump l) l 0)))
299 (and hypropos-show-brief-docs 288 (and hypropos-show-brief-docs
300 (setq doc (documentation fn)) 289 (setq doc (documentation fn))
301 (insert-face (if doc 290 (insert-face (if doc
302 (concat " - " 291 (concat " - "
303 (substring doc 0 (string-match "\n" doc))) 292 (substring doc 0 (string-match "\n" doc)))
304 " Not documented.") 293 " Not documented.")
305 'documentation)) 294 'hypropos-documentation))
306 (insert ?\n) 295 (insert ?\n))))
307 (setq fns (cdr fns))
308 )))
309 296
310 (defun hypropos-grok-variables (vars) 297 (defun hypropos-grok-variables (vars)
311 (let (var doc userp) 298 (let (doc userp)
312 (while (setq var (car vars)) 299 (dolist (var vars)
313 (setq userp (user-variable-p var) 300 (setq userp (user-variable-p var))
314 vars (cdr vars))
315 (insert (if userp " * " " ")) 301 (insert (if userp " * " " "))
316 (insert-face (format "%-30S" var) 'hyperlink) 302 (let ((e (insert-face (format "%S" var) 'hypropos-hyperlink)))
303 (set-extent-property e 'mouse-face 'highlight))
304 (insert-char ?\ (let ((l (- 30 (length (format "%S" var)))))
305 (if (natnump l) l 0)))
317 (and hypropos-show-brief-docs 306 (and hypropos-show-brief-docs
318 (setq doc (documentation-property var 'variable-documentation)) 307 (setq doc (documentation-property var 'variable-documentation))
319 (insert-face (if doc 308 (insert-face (if doc
320 (concat " - " (substring doc (if userp 1 0) 309 (concat " - " (substring doc (if userp 1 0)
321 (string-match "\n" doc))) 310 (string-match "\n" doc)))
322 " - Not documented.") 311 " - Not documented.")
323 'documentation)) 312 'hypropos-documentation))
324 (insert ?\n) 313 (insert ?\n))))
325 )))
326 314
327 ;; ---------------------------------------------------------------------- ;; 315 ;; ---------------------------------------------------------------------- ;;
328 316
329 (defun hyper-apropos-mode (regexp) 317 (defun hyper-apropos-mode (regexp)
330 "Improved apropos mode for displaying Emacs documentation. Function and 318 "Improved apropos mode for displaying Emacs documentation. Function and
359 truncate-lines t 347 truncate-lines t
360 hypropos-last-regexp regexp 348 hypropos-last-regexp regexp
361 modeline-buffer-identification 349 modeline-buffer-identification
362 (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ") 350 (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ")
363 (cons modeline-buffer-id-right-extent (concat "\"" regexp "\"")))) 351 (cons modeline-buffer-id-right-extent (concat "\"" regexp "\""))))
364 (setq mode-motion-hook 'mode-motion-highlight-line)
365 (use-local-map hypropos-map) 352 (use-local-map hypropos-map)
366 (run-hooks 'hyper-apropos-mode-hook)) 353 (run-hooks 'hyper-apropos-mode-hook))
367 354
368 ;; ---------------------------------------------------------------------- ;; 355 ;; ---------------------------------------------------------------------- ;;
369 356
545 (if (or win (> arg 0)) 532 (if (or win (> arg 0))
546 (hypropos-get-doc (car hypropos-help-history) t) 533 (hypropos-get-doc (car hypropos-help-history) t)
547 (display-buffer hypropos-help-buf)))) 534 (display-buffer hypropos-help-buf))))
548 535
549 (defun hypropos-insert-face (string &optional face) 536 (defun hypropos-insert-face (string &optional face)
550 "Insert STRING and fontify some parts with face `hyperlink'." 537 "Insert STRING and fontify some parts with face `hypropos-hyperlink'."
551 (let ((beg (point)) end) 538 (let ((beg (point)) end)
552 (insert-face string (or face 'documentation)) 539 (insert-face string (or face 'hypropos-documentation))
553 (setq end (point)) 540 (setq end (point))
554 (goto-char beg) 541 (goto-char beg)
555 (while (re-search-forward 542 (while (re-search-forward
556 "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'" 543 "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'"
557 end 'limit) 544 end 'limit)
558 (set-extent-face (make-extent (match-beginning 1) (match-end 1)) 545 (let ((e (make-extent (match-beginning 1) (match-end 1))))
559 'hyperlink)) 546 (set-extent-face e 'hypropos-hyperlink)
547 (set-extent-property e 'mouse-face 'highlight))
560 (goto-char beg) 548 (goto-char beg)
561 (while (re-search-forward 549 (while (re-search-forward
562 "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)" 550 "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)"
563 end 'limit) 551 end 'limit)
564 (set-extent-face (make-extent (match-beginning 1) (match-end 1)) 552 (let ((e (make-extent (match-beginning 1) (match-end 1))))
565 'hyperlink)))) 553 (set-extent-face e 'hypropos-hyperlink)
554 (set-extent-property e 'mouse-face 'highlight))))))
566 555
567 (defun hypropos-insert-keybinding (keys string) 556 (defun hypropos-insert-keybinding (keys string)
568 (if keys 557 (if keys
569 (insert " (" string " bound to \"" 558 (insert " (" string " bound to \""
570 (mapconcat 'key-description 559 (mapconcat 'key-description
571 (sort keys #'(lambda (x y) 560 (sort* keys #'< :key #'length)
572 (< (length x) (length y))))
573 "\", \"") 561 "\", \"")
574 "\")\n"))) 562 "\")\n")))
575 563
576 (defun hypropos-insert-section-heading (alias-desc &optional desc) 564 (defun hypropos-insert-section-heading (alias-desc &optional desc)
577 (or desc (setq desc alias-desc 565 (or desc (setq desc alias-desc
583 ", an " ", a ") 571 ", an " ", a ")
584 desc))) 572 desc)))
585 (aset desc 0 (upcase (aref desc 0))) ; capitalize 573 (aset desc 0 (upcase (aref desc 0))) ; capitalize
586 (goto-char (point-max)) 574 (goto-char (point-max))
587 (newline 3) (delete-blank-lines) (newline 2) 575 (newline 3) (delete-blank-lines) (newline 2)
588 (hypropos-insert-face desc 'section-heading)) 576 (hypropos-insert-face desc 'hypropos-section-heading))
589 577
590 (defun hypropos-insert-value (string symbol val) 578 (defun hypropos-insert-value (string symbol val)
591 (insert-face string 'heading) 579 (insert-face string 'hypropos-heading)
592 (insert (if (symbol-value symbol) 580 (insert (if (symbol-value symbol)
593 (if (or (null val) (eq val t) (integerp val)) 581 (if (or (null val) (eq val t) (integerp val))
594 (prog1 582 (prog1
595 (symbol-value symbol) 583 (symbol-value symbol)
596 (set symbol nil)) 584 (set symbol nil))
663 (save-excursion 651 (save-excursion
664 (set-buffer (get-buffer-create hypropos-help-buf)) 652 (set-buffer (get-buffer-create hypropos-help-buf))
665 ;;(setq standard-output (current-buffer)) 653 ;;(setq standard-output (current-buffer))
666 (setq buffer-read-only nil) 654 (setq buffer-read-only nil)
667 (erase-buffer) 655 (erase-buffer)
668 (insert-face (format "`%s'" symbol) 'major-heading) 656 (insert-face (format "`%s'" symbol) 'hypropos-major-heading)
669 (insert (format " (buffer: %s, mode: %s)\n" 657 (insert (format " (buffer: %s, mode: %s)\n"
670 (buffer-name hypropos-ref-buffer) 658 (buffer-name hypropos-ref-buffer)
671 local))) 659 local)))
672 ;; function ---------------------------------------------------------- 660 ;; function ----------------------------------------------------------
673 (and (memq 'function type) 661 (and (memq 'function type)
691 (cdr (assq symtype 679 (cdr (assq symtype
692 '((subr . "built-in ") 680 '((subr . "built-in ")
693 (bytecode . "compiled Lisp ") 681 (bytecode . "compiled Lisp ")
694 (autoload . "autoloaded Lisp ") 682 (autoload . "autoloaded Lisp ")
695 (lambda . "Lisp ")))) 683 (lambda . "Lisp "))))
696 desc) 684 desc
685 (if (eq symtype 'autoload)
686 (format ", (autoloaded from \"%s\")"
687 (nth 1 newsym))))
697 local (current-local-map) 688 local (current-local-map)
698 global (current-global-map) 689 global (current-global-map)
699 obsolete (get symbol 'byte-obsolete-info) 690 obsolete (get symbol 'byte-obsolete-info)
700 doc (or (documentation symbol) "function not documented")) 691 doc (or (documentation symbol) "function not documented"))
701 (save-excursion 692 (save-excursion
702 (set-buffer hypropos-help-buf) 693 (set-buffer hypropos-help-buf)
703 (goto-char (point-max)) 694 (goto-char (point-max))
704 (setq standard-output (current-buffer)) 695 (setq standard-output (current-buffer))
705 (hypropos-insert-section-heading alias-desc desc) 696 (hypropos-insert-section-heading alias-desc desc)
706 (and (eq symtype 'autoload)
707 (insert (format ", (autoloaded from \"%s\")"
708 (nth 1 newsym))))
709 (insert ":\n") 697 (insert ":\n")
710 (if local 698 (if local
711 (hypropos-insert-keybinding 699 (hypropos-insert-keybinding
712 (where-is-internal symbol (list local) nil nil nil) 700 (where-is-internal symbol (list local) nil nil nil)
713 "locally")) 701 "locally"))
719 (hypropos-insert-face 707 (hypropos-insert-face
720 (format "%s is an obsolete function; %s\n\n" symbol 708 (format "%s is an obsolete function; %s\n\n" symbol
721 (if (stringp (car obsolete)) 709 (if (stringp (car obsolete))
722 (car obsolete) 710 (car obsolete)
723 (format "use `%s' instead." (car obsolete)))) 711 (format "use `%s' instead." (car obsolete))))
724 'warning)) 712 'hypropos-warning))
725 (setq beg (point)) 713 (setq beg (point))
726 (insert-face "arguments: " 'heading) 714 (insert-face "arguments: " 'hypropos-heading)
727 (cond ((eq symtype 'lambda) 715 (cond ((eq symtype 'lambda)
728 (princ (or (nth 1 newsym) "()"))) 716 (princ (or (nth 1 newsym) "()")))
729 ((eq symtype 'bytecode) 717 ((eq symtype 'bytecode)
730 (princ (or (aref newsym 0) "()"))) 718 (princ (or (aref newsym 0) "()")))
731 ((and (eq symtype 'subr) 719 ((and (eq symtype 'subr)
736 (match-beginning 1) 724 (match-beginning 1)
737 (match-end 1))) 725 (match-end 1)))
738 (setq doc (substring doc 0 (match-beginning 0)))) 726 (setq doc (substring doc 0 (match-beginning 0))))
739 ((and (eq symtype 'subr) 727 ((and (eq symtype 'subr)
740 (string-match 728 (string-match
741 "[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)" 729 "\
730 \[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
742 doc)) 731 doc))
743 (insert "(" 732 (insert "("
744 (if (match-end 1) 733 (if (match-end 1)
745 (substring doc 734 (substring doc
746 (match-beginning 1) 735 (match-beginning 1)
765 alias-desc (cdr aliases)) 754 alias-desc (cdr aliases))
766 (setq symtype (or (local-variable-p newsym (current-buffer)) 755 (setq symtype (or (local-variable-p newsym (current-buffer))
767 (and (local-variable-p newsym 756 (and (local-variable-p newsym
768 (current-buffer) t) 757 (current-buffer) t)
769 'auto-local)) 758 'auto-local))
770 desc (concat (if (user-variable-p newsym) 759 desc (concat (and (get newsym 'custom-type)
760 "customizable ")
761 (if (user-variable-p newsym)
771 "user variable" 762 "user variable"
772 "variable") 763 "variable")
773 (cond ((eq symtype t) ", buffer-local") 764 (cond ((eq symtype t) ", buffer-local")
774 ((eq symtype 'auto-local) 765 ((eq symtype 'auto-local)
775 ", local when set"))) 766 ", local when set")))
790 (save-excursion 781 (save-excursion
791 (set-buffer hypropos-help-buf) 782 (set-buffer hypropos-help-buf)
792 (goto-char (point-max)) 783 (goto-char (point-max))
793 (setq standard-output (current-buffer)) 784 (setq standard-output (current-buffer))
794 (hypropos-insert-section-heading alias-desc desc) 785 (hypropos-insert-section-heading alias-desc desc)
786 (when (and (user-variable-p newsym)
787 (get newsym 'custom-type))
788 (let ((e (make-extent (point-at-bol) (point))))
789 (set-extent-property e 'mouse-face 'highlight)
790 (set-extent-property e 'help-echo
791 (format "Customize %s" newsym))
792 (set-extent-property
793 e 'hypropos-custom
794 `(lambda () (customize-variable (quote ,newsym))))))
795 (insert ":\n\n") 795 (insert ":\n\n")
796 (setq beg (point)) 796 (setq beg (point))
797 (if obsolete 797 (if obsolete
798 (hypropos-insert-face 798 (hypropos-insert-face
799 (format "%s is an obsolete function; %s\n\n" symbol 799 (format "%s is an obsolete function; %s\n\n" symbol
800 (if (stringp obsolete) 800 (if (stringp obsolete)
801 obsolete 801 obsolete
802 (format "use `%s' instead." obsolete))) 802 (format "use `%s' instead." obsolete)))
803 'warning)) 803 'hypropos-warning))
804 ;; generally, the value of the variable is short and the 804 ;; generally, the value of the variable is short and the
805 ;; documentation of the variable long, so it's desirable 805 ;; documentation of the variable long, so it's desirable
806 ;; to see all of the value and the start of the 806 ;; to see all of the value and the start of the
807 ;; documentation. Some variables, though, have huge and 807 ;; documentation. Some variables, though, have huge and
808 ;; nearly meaningless values that force you to page 808 ;; nearly meaningless values that force you to page
809 ;; forward just to find the doc string. That is 809 ;; forward just to find the doc string. That is
810 ;; undesirable. 810 ;; undesirable.
811 (if (and (or (null local-str) (< (length local-str) 69)) 811 (if (and (or (null local-str) (< (length local-str) 69))
812 (or (null global-str) (< (length global-str) 69))) 812 (or (null global-str) (< (length global-str) 69)))
813 ; 80 cols. docstrings assume this. 813 ; 80 cols. docstrings assume this.
814 (progn (insert-face "value: " 'heading) 814 (progn (insert-face "value: " 'hypropos-heading)
815 (insert (or local-str "is void")) 815 (insert (or local-str "is void"))
816 (if (eq symtype t) 816 (if (eq symtype t)
817 (progn 817 (progn
818 (insert "\n") 818 (insert "\n")
819 (insert-face "default value: " 'heading) 819 (insert-face "default value: " 'hypropos-heading)
820 (insert (or global-str "is void")))) 820 (insert (or global-str "is void"))))
821 (insert "\n\n") 821 (insert "\n\n")
822 (hypropos-insert-face doc)) 822 (hypropos-insert-face doc))
823 (hypropos-insert-value "value: " 'local-str local) 823 (hypropos-insert-value "value: " 'local-str local)
824 (if (eq symtype t) 824 (if (eq symtype t)
829 (insert "\n\n") 829 (insert "\n\n")
830 (hypropos-insert-face doc) 830 (hypropos-insert-face doc)
831 (if local-str 831 (if local-str
832 (progn 832 (progn
833 (newline 3) (delete-blank-lines) (newline 1) 833 (newline 3) (delete-blank-lines) (newline 1)
834 (insert-face "value: " 'heading) 834 (insert-face "value: " 'hypropos-heading)
835 (if hypropos-prettyprint-long-values 835 (if hypropos-prettyprint-long-values
836 (condition-case nil 836 (condition-case nil
837 (let ((pp-print-readably nil)) (pprint local)) 837 (let ((pp-print-readably nil)) (pprint local))
838 (error (insert local-str))) 838 (error (insert local-str)))
839 (insert local-str)))) 839 (insert local-str))))
840 (if global-str 840 (if global-str
841 (progn 841 (progn
842 (newline 3) (delete-blank-lines) (newline 1) 842 (newline 3) (delete-blank-lines) (newline 1)
843 (insert-face "default value: " 'heading) 843 (insert-face "default value: " 'hypropos-heading)
844 (if hypropos-prettyprint-long-values 844 (if hypropos-prettyprint-long-values
845 (condition-case nil 845 (condition-case nil
846 (let ((pp-print-readably nil)) (pprint global)) 846 (let ((pp-print-readably nil)) (pprint global))
847 (error (insert global-str))) 847 (error (insert global-str)))
848 (insert global-str))))) 848 (insert global-str)))))
873 doc (face-doc-string symbol)) 873 doc (face-doc-string symbol))
874 ;; #### - add some code here 874 ;; #### - add some code here
875 (save-excursion 875 (save-excursion
876 (set-buffer hypropos-help-buf) 876 (set-buffer hypropos-help-buf)
877 (setq standard-output (current-buffer)) 877 (setq standard-output (current-buffer))
878 (hypropos-insert-section-heading "Face:\n\n ") 878 (hypropos-insert-section-heading
879 (insert-face "ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789" 879 (concat "Face"
880 (when (get symbol 'face-defface-spec)
881 (let* ((str " (customizable)")
882 (e (make-extent 1 (length str) str)))
883 (set-extent-property e 'mouse-face 'highlight)
884 (set-extent-property e 'help-echo
885 (format "Customize %s" symbol))
886 (set-extent-property e 'unique t)
887 (set-extent-property e 'duplicable t)
888 (set-extent-property
889 e 'hypropos-custom
890 `(lambda () (customize-face (quote ,symbol))))
891 str))
892 ":\n\n "))
893 (insert-face "\
894 ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
880 'hypropos-temp-face) 895 'hypropos-temp-face)
881 (newline 2) 896 (newline 2)
882 (insert-face " Font: " 'heading) 897 (insert-face " Font: " 'hypropos-heading)
883 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n") 898 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
884 (and (cdr font) 899 (and (cdr font)
885 (font-instance-name (cdr font))))) 900 (font-instance-name (cdr font)))))
886 (insert-face " Foreground: " 'heading) 901 (insert-face " Foreground: " 'hypropos-heading)
887 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n") 902 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
888 (and (cdr fore) 903 (and (cdr fore)
889 (color-instance-name (cdr fore))))) 904 (color-instance-name (cdr fore)))))
890 (insert-face " Background: " 'heading) 905 (insert-face " Background: " 'hypropos-heading)
891 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n") 906 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
892 (and (cdr back) 907 (and (cdr back)
893 (color-instance-name (cdr back))))) 908 (color-instance-name (cdr back)))))
894 (insert-face " Underline: " 'heading) 909 (insert-face " Underline: " 'hypropos-heading)
895 (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n") 910 (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n")
896 (cdr undl))) 911 (cdr undl)))
897 (if doc 912 (if doc
898 (progn 913 (progn
899 (newline) 914 (newline)
918 (if (memq (car symtype) 933 (if (memq (car symtype)
919 '(variable-documentation byte-obsolete-info)) 934 '(variable-documentation byte-obsolete-info))
920 (setq symtype (cdr symtype)) 935 (setq symtype (cdr symtype))
921 (insert-face (concat " " (symbol-name (car symtype)) 936 (insert-face (concat " " (symbol-name (car symtype))
922 ": ") 937 ": ")
923 'heading) 938 'hypropos-heading)
924 (setq symtype (cdr symtype)) 939 (setq symtype (cdr symtype))
925 (indent-to 32) 940 (indent-to 32)
926 (insert (prin1-to-string (car symtype)) "\n")) 941 (insert (prin1-to-string (car symtype)) "\n"))
927 (setq symtype (cdr symtype))))))) 942 (setq symtype (cdr symtype)))))))
928 (save-excursion 943 (save-excursion
942 "Major mode for hypertext XEmacs help. In this mode, you can quickly 957 "Major mode for hypertext XEmacs help. In this mode, you can quickly
943 follow links between back and forth between the documentation strings for 958 follow links between back and forth between the documentation strings for
944 different variables and functions. Common commands: 959 different variables and functions. Common commands:
945 960
946 \\{hypropos-help-map}" 961 \\{hypropos-help-map}"
947 (setq mode-motion-hook 'hypropos-highlight-lisp-symbol 962 (setq buffer-read-only t
948 buffer-read-only t
949 major-mode 'hyper-help-mode 963 major-mode 'hyper-help-mode
950 mode-name "Hyper-Help") 964 mode-name "Hyper-Help")
951 (set-syntax-table emacs-lisp-mode-syntax-table) 965 (set-syntax-table emacs-lisp-mode-syntax-table)
966 (hypropos-highlightify)
952 (use-local-map hypropos-help-map)) 967 (use-local-map hypropos-help-map))
953 968
954 (defun hypropos-highlight-lisp-symbol (event) 969 ;; ---------------------------------------------------------------------- ;;
955 ;; mostly copied from mode-motion-highlight-internal 970
956 (let* ((window (event-window event)) 971 (defun hypropos-highlightify ()
957 (buffer (and window (window-buffer window))) 972 (save-excursion
958 (point (and buffer (event-point event))) 973 (goto-char (point-min))
959 st en sym highlight-p) 974 (let ((st (point-min))
960 (if buffer 975 sym)
961 (progn 976 (while (not (eobp))
962 (set-buffer buffer) 977 (if (zerop (skip-syntax-forward "w_"))
963 (if point 978 (forward-char 1)
964 (save-excursion 979 (and (> (- (point) st) 3)
965 (goto-char point) 980 (setq sym (intern-soft (buffer-substring st (point))))
966 (setq st (save-excursion 981 (or (boundp sym)
967 (skip-syntax-backward "w_") 982 (fboundp sym))
968 (skip-chars-forward "`") 983 (set-extent-property (make-extent st (point))
969 (point)) 984 'mouse-face 'highlight)))
970 en (save-excursion 985 (setq st (point))))))
971 (goto-char st)
972 (skip-syntax-forward "w_")
973 (skip-chars-backward ".")
974 (point))
975 sym (and (not (eq st en))
976 (intern-soft (buffer-substring st en)))
977 highlight-p (and sym
978 (or (boundp sym)
979 (fboundp sym))))
980 (if highlight-p
981 (if mode-motion-extent
982 (set-extent-endpoints mode-motion-extent st en)
983 (setq mode-motion-extent (make-extent st en))
984 (set-extent-property mode-motion-extent 'highlight t))
985 (and mode-motion-extent
986 (progn (delete-extent mode-motion-extent)
987 (setq mode-motion-extent nil)))
988 ))
989 ;; not over text; zero the extent.
990 (if (and mode-motion-extent (extent-buffer mode-motion-extent)
991 (not (eq (extent-start-position mode-motion-extent)
992 (extent-end-position mode-motion-extent))))
993 (set-extent-endpoints mode-motion-extent 1 1)))))))
994
995 986
996 ;; ---------------------------------------------------------------------- ;; 987 ;; ---------------------------------------------------------------------- ;;
997 988
998 (defun hypropos-scroll-up () 989 (defun hypropos-scroll-up ()
999 "Scroll up the \"*Hyper Help*\" buffer if it's visible, or scroll this window up." 990 "Scroll up the \"*Hyper Help*\" buffer if it's visible, or scroll this window up."
1027 1018
1028 (defun hypropos-mouse-get-doc (event) 1019 (defun hypropos-mouse-get-doc (event)
1029 "Get the documentation for the symbol the mouse is on." 1020 "Get the documentation for the symbol the mouse is on."
1030 (interactive "e") 1021 (interactive "e")
1031 (mouse-set-point event) 1022 (mouse-set-point event)
1032 (save-excursion 1023 (let ((e (extent-at (point) nil 'hypropos-custom)))
1033 (let ((symbol (hypropos-this-symbol))) 1024 (if e
1034 (if symbol 1025 (funcall (extent-property e 'hypropos-custom))
1035 (hypropos-get-doc symbol) 1026 (save-excursion
1036 (error "Click on a symbol"))))) 1027 (let ((symbol (hypropos-this-symbol)))
1028 (if symbol
1029 (hypropos-get-doc symbol)
1030 (error "Click on a symbol")))))))
1037 1031
1038 ;; ---------------------------------------------------------------------- ;; 1032 ;; ---------------------------------------------------------------------- ;;
1039 1033
1040 (defun hypropos-add-keyword (pattern) 1034 (defun hypropos-add-keyword (pattern)
1041 "Use additional keyword to narrow regexp match. 1035 "Use additional keyword to narrow regexp match.
1154 (and (symbolp val) 1148 (and (symbolp val)
1155 (not (memq val '(t nil))))) 1149 (not (memq val '(t nil)))))
1156 "'%s" "%s") 1150 "'%s" "%s")
1157 str)) 1151 str))
1158 (error nil))))))) 1152 (error nil)))))))
1153
1154 (defun hypropos-customize-variable ()
1155 (interactive)
1156 (let ((var (hypropos-this-symbol)))
1157 (customize-variable var)))
1159 1158
1160 ;; ---------------------------------------------------------------------- ;; 1159 ;; ---------------------------------------------------------------------- ;;
1161 1160
1162 (defun hypropos-find-tag (&optional tag-name) 1161 (defun hypropos-find-tag (&optional tag-name)
1163 "Find the tag for the symbol on the current line in other window. In 1162 "Find the tag for the symbol on the current line in other window. In
1221 (mouse-set-point event) 1220 (mouse-set-point event)
1222 (let* ((sym (hypropos-this-symbol)) 1221 (let* ((sym (hypropos-this-symbol))
1223 (notjunk (not (null sym))) 1222 (notjunk (not (null sym)))
1224 (command-p (if (commandp sym) t)) 1223 (command-p (if (commandp sym) t))
1225 (variable-p (and sym (boundp sym))) 1224 (variable-p (and sym (boundp sym)))
1225 (customizable-p (and variable-p
1226 (get sym 'custom-type)
1227 t))
1226 (function-p (fboundp sym)) 1228 (function-p (fboundp sym))
1227 (apropos-p (eq 'hyper-apropos-mode 1229 (apropos-p (eq 'hyper-apropos-mode
1228 (save-excursion (set-buffer (event-buffer event)) 1230 (save-excursion (set-buffer (event-buffer event))
1229 major-mode))) 1231 major-mode)))
1230 (name (if sym (symbol-name sym) "")) 1232 (name (if sym (symbol-name sym) ""))
1232 (delete 1234 (delete
1233 nil 1235 nil
1234 (list (concat "Hyper-Help: " name) 1236 (list (concat "Hyper-Help: " name)
1235 (vector "Display documentation" 'hypropos-get-doc notjunk) 1237 (vector "Display documentation" 'hypropos-get-doc notjunk)
1236 (vector "Set variable" 'hypropos-set-variable variable-p) 1238 (vector "Set variable" 'hypropos-set-variable variable-p)
1239 (vector "Customize variable" 'hypropos-customize-variable
1240 customizable-p)
1237 (vector "Show keys for" 'hypropos-where-is command-p) 1241 (vector "Show keys for" 'hypropos-where-is command-p)
1238 (vector "Invoke command" 'hypropos-invoke-fn command-p) 1242 (vector "Invoke command" 'hypropos-invoke-fn command-p)
1239 (vector "Find tag" 'hypropos-find-tag notjunk) 1243 (vector "Find tag" 'hypropos-find-tag notjunk)
1240 (and apropos-p 1244 (and apropos-p
1241 ["Add keyword..." hypropos-add-keyword t]) 1245 ["Add keyword..." hypropos-add-keyword t])