Mercurial > emacs
annotate lisp/emacs-lisp/eieio-opt.el @ 110682:ba6a1c230532
gnus-html.el (gnus-html-prefetch-images): Adjust regexp to avoid regexp backtrace overflows.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Fri, 01 Oct 2010 13:33:03 +0000 |
parents | 280c8ae2476d |
children | 417b1e4d63cd |
rev | line source |
---|---|
105237 | 1 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) |
2 | |
105327 | 3 ;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008, |
106815 | 4 ;; 2009, 2010 Free Software Foundation, Inc. |
105237 | 5 |
105327 | 6 ;; Author: Eric M. Ludlam <zappo@gnu.org> |
105237 | 7 ;; Version: 0.2 |
8 ;; Keywords: OO, lisp | |
110015
280c8ae2476d
Add "Package:" file headers to denote built-in packages.
Chong Yidong <cyd@stupidchicken.com>
parents:
106815
diff
changeset
|
9 ;; Package: eieio |
105237 | 10 |
11 ;; This file is part of GNU Emacs. | |
12 | |
13 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
14 ;; it under the terms of the GNU General Public License as published by | |
15 ;; the Free Software Foundation, either version 3 of the License, or | |
16 ;; (at your option) any later version. | |
17 | |
18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; You should have received a copy of the GNU General Public License | |
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
25 | |
26 ;;; Commentary: | |
27 ;; | |
28 ;; This contains support functions to eieio. These functions contain | |
29 ;; some small class browser and class printing functions. | |
30 ;; | |
31 | |
32 (require 'eieio) | |
33 | |
34 ;;; Code: | |
35 (defun eieio-browse (&optional root-class) | |
36 "Create an object browser window to show all objects. | |
37 If optional ROOT-CLASS, then start with that, otherwise start with | |
38 variable `eieio-default-superclass'." | |
39 (interactive (if current-prefix-arg | |
40 (list (read (completing-read "Class: " | |
41 (eieio-build-class-alist) | |
42 nil t))) | |
43 nil)) | |
44 (if (not root-class) (setq root-class 'eieio-default-superclass)) | |
45 (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class))) | |
46 (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) | |
105813
df4934f25eef
* textmodes/two-column.el (2C-split):
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
105474
diff
changeset
|
47 (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") |
105237 | 48 (erase-buffer) |
49 (goto-char 0) | |
50 (eieio-browse-tree root-class "" "") | |
51 )) | |
52 | |
53 (defun eieio-browse-tree (this-root prefix ch-prefix) | |
105474 | 54 "Recursively draw the children of the given class on the screen. |
105237 | 55 Argument THIS-ROOT is the local root of the tree. |
56 Argument PREFIX is the character prefix to use. | |
57 Argument CH-PREFIX is another character prefix to display." | |
58 (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root))) | |
59 (let ((myname (symbol-name this-root)) | |
60 (chl (aref (class-v this-root) class-children)) | |
61 (fprefix (concat ch-prefix " +--")) | |
62 (mprefix (concat ch-prefix " | ")) | |
63 (lprefix (concat ch-prefix " "))) | |
64 (insert prefix myname "\n") | |
65 (while (cdr chl) | |
66 (eieio-browse-tree (car chl) fprefix mprefix) | |
67 (setq chl (cdr chl))) | |
68 (if chl | |
69 (eieio-browse-tree (car chl) fprefix lprefix)) | |
70 )) | |
71 | |
72 ;;; CLASS COMPLETION / DOCUMENTATION | |
73 | |
74 (defalias 'describe-class 'eieio-describe-class) | |
75 | |
76 (defun eieio-describe-class (class &optional headerfcn) | |
77 "Describe a CLASS defined by a string or symbol. | |
105327 | 78 If CLASS is actually an object, then also display current values of that object. |
105237 | 79 Optional HEADERFCN should be called to insert a few bits of info first." |
80 (interactive (list (eieio-read-class "Class: "))) | |
81 (with-output-to-temp-buffer (help-buffer) ;"*Help*" | |
82 (help-setup-xref (list #'eieio-describe-class class headerfcn) | |
105372
bd2966850aac
Use `called-interactively-p' instead of `interactive-p'.
Juanma Barranquero <lekktu@gmail.com>
parents:
105327
diff
changeset
|
83 (called-interactively-p 'interactive)) |
105237 | 84 |
85 (when headerfcn (funcall headerfcn)) | |
86 | |
87 (if (class-option class :abstract) | |
88 (princ "Abstract ")) | |
89 (princ "Class ") | |
90 (prin1 class) | |
91 (terpri) | |
92 ;; Inheritence tree information | |
93 (let ((pl (class-parents class))) | |
94 (when pl | |
95 (princ " Inherits from ") | |
96 (while pl | |
97 (princ "`") (prin1 (car pl)) (princ "'") | |
98 (setq pl (cdr pl)) | |
99 (if pl (princ ", "))) | |
100 (terpri))) | |
101 (let ((ch (class-children class))) | |
102 (when ch | |
103 (princ " Children ") | |
104 (while ch | |
105 (princ "`") (prin1 (car ch)) (princ "'") | |
106 (setq ch (cdr ch)) | |
107 (if ch (princ ", "))) | |
108 (terpri))) | |
109 (terpri) | |
110 ;; System documentation | |
111 (let ((doc (documentation-property class 'variable-documentation))) | |
112 (when doc | |
113 (princ "Documentation:") | |
114 (terpri) | |
115 (princ doc) | |
116 (terpri) | |
117 (terpri))) | |
118 ;; Describe all the slots in this class | |
119 (eieio-describe-class-slots class) | |
120 ;; Describe all the methods specific to this class. | |
121 (let ((methods (eieio-all-generic-functions class)) | |
122 (doc nil)) | |
123 (if (not methods) nil | |
124 (princ "Specialized Methods:") | |
125 (terpri) | |
126 (terpri) | |
127 (while methods | |
128 (setq doc (eieio-method-documentation (car methods) class)) | |
129 (princ "`") | |
130 (prin1 (car methods)) | |
131 (princ "'") | |
132 (if (not doc) | |
133 (princ " Undocumented") | |
134 (if (car doc) | |
135 (progn | |
136 (princ " :STATIC ") | |
137 (prin1 (car (car doc))) | |
138 (terpri) | |
139 (princ (cdr (car doc))))) | |
140 (setq doc (cdr doc)) | |
141 (if (car doc) | |
142 (progn | |
143 (princ " :BEFORE ") | |
144 (prin1 (car (car doc))) | |
145 (terpri) | |
146 (princ (cdr (car doc))))) | |
147 (setq doc (cdr doc)) | |
148 (if (car doc) | |
149 (progn | |
150 (princ " :PRIMARY ") | |
151 (prin1 (car (car doc))) | |
152 (terpri) | |
153 (princ (cdr (car doc))))) | |
154 (setq doc (cdr doc)) | |
155 (if (car doc) | |
156 (progn | |
157 (princ " :AFTER ") | |
158 (prin1 (car (car doc))) | |
159 (terpri) | |
160 (princ (cdr (car doc))))) | |
161 (terpri) | |
162 (terpri)) | |
163 (setq methods (cdr methods)))))) | |
105813
df4934f25eef
* textmodes/two-column.el (2C-split):
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
105474
diff
changeset
|
164 (with-current-buffer (help-buffer) |
105237 | 165 (buffer-string))) |
166 | |
167 (defun eieio-describe-class-slots (class) | |
168 "Describe the slots in CLASS. | |
169 Outputs to the standard output." | |
170 (let* ((cv (class-v class)) | |
171 (docs (aref cv class-public-doc)) | |
172 (names (aref cv class-public-a)) | |
173 (deflt (aref cv class-public-d)) | |
174 (types (aref cv class-public-type)) | |
175 (publp (aref cv class-public-printer)) | |
176 (i 0) | |
177 (prot (aref cv class-protection)) | |
178 ) | |
179 (princ "Instance Allocated Slots:") | |
180 (terpri) | |
181 (terpri) | |
182 (while names | |
183 (if (car prot) (princ "Private ")) | |
184 (princ "Slot: ") | |
185 (prin1 (car names)) | |
186 (when (not (eq (aref types i) t)) | |
187 (princ " type = ") | |
188 (prin1 (aref types i))) | |
189 (unless (eq (car deflt) eieio-unbound) | |
190 (princ " default = ") | |
191 (prin1 (car deflt))) | |
192 (when (car publp) | |
193 (princ " printer = ") | |
194 (prin1 (car publp))) | |
195 (when (car docs) | |
196 (terpri) | |
197 (princ " ") | |
198 (princ (car docs)) | |
199 (terpri)) | |
200 (terpri) | |
201 (setq names (cdr names) | |
202 docs (cdr docs) | |
203 deflt (cdr deflt) | |
204 publp (cdr publp) | |
205 prot (cdr prot) | |
206 i (1+ i))) | |
207 (setq docs (aref cv class-class-allocation-doc) | |
208 names (aref cv class-class-allocation-a) | |
209 types (aref cv class-class-allocation-type) | |
210 i 0 | |
211 prot (aref cv class-class-allocation-protection)) | |
212 (when names | |
213 (terpri) | |
214 (princ "Class Allocated Slots:")) | |
215 (terpri) | |
216 (terpri) | |
217 (while names | |
218 (when (car prot) | |
219 (princ "Private ")) | |
220 (princ "Slot: ") | |
221 (prin1 (car names)) | |
222 (unless (eq (aref types i) t) | |
223 (princ " type = ") | |
224 (prin1 (aref types i))) | |
225 (condition-case nil | |
226 (let ((value (eieio-oref class (car names)))) | |
227 (princ " value = ") | |
228 (prin1 value)) | |
229 (error nil)) | |
230 (when (car docs) | |
231 (terpri) | |
232 (princ " ") | |
233 (princ (car docs)) | |
234 (terpri)) | |
235 (terpri) | |
236 (setq names (cdr names) | |
237 docs (cdr docs) | |
238 prot (cdr prot) | |
239 i (1+ i))))) | |
240 | |
241 (defun eieio-describe-constructor (fcn) | |
242 "Describe the constructor function FCN. | |
243 Uses `eieio-describe-class' to describe the class being constructed." | |
244 (interactive | |
245 ;; Use eieio-read-class since all constructors have the same name as | |
246 ;; the class they create. | |
247 (list (eieio-read-class "Class: "))) | |
248 (eieio-describe-class | |
249 fcn (lambda () | |
250 ;; Describe the constructor part. | |
251 (princ "Object Constructor Function: ") | |
252 (prin1 fcn) | |
253 (terpri) | |
254 (princ "Creates an object of class ") | |
255 (prin1 fcn) | |
256 (princ ".") | |
257 (terpri) | |
258 (terpri) | |
259 )) | |
260 ) | |
261 | |
262 (defun eieio-build-class-alist (&optional class instantiable-only buildlist) | |
263 "Return an alist of all currently active classes for completion purposes. | |
264 Optional argument CLASS is the class to start with. | |
265 If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
266 are not abstract, otherwise allow all classes. | |
267 Optional argument BUILDLIST is more list to attach and is used internally." | |
268 (let* ((cc (or class eieio-default-superclass)) | |
269 (sublst (aref (class-v cc) class-children))) | |
270 (if (or (not instantiable-only) (not (class-abstract-p cc))) | |
271 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))) | |
272 (while sublst | |
273 (setq buildlist (eieio-build-class-alist | |
274 (car sublst) instantiable-only buildlist)) | |
275 (setq sublst (cdr sublst))) | |
276 buildlist)) | |
277 | |
278 (defvar eieio-read-class nil | |
279 "History of the function `eieio-read-class' prompt.") | |
280 | |
281 (defun eieio-read-class (prompt &optional histvar instantiable-only) | |
282 "Return a class chosen by the user using PROMPT. | |
283 Optional argument HISTVAR is a variable to use as history. | |
284 If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
285 are not abstract." | |
286 (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only) | |
287 nil t nil | |
288 (or histvar 'eieio-read-class)))) | |
289 | |
290 (defun eieio-read-subclass (prompt class &optional histvar instantiable-only) | |
291 "Return a class chosen by the user using PROMPT. | |
292 CLASS is the base class, and completion occurs across all subclasses. | |
293 Optional argument HISTVAR is a variable to use as history. | |
294 If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
295 are not abstract." | |
296 (intern (completing-read prompt | |
297 (eieio-build-class-alist class instantiable-only) | |
298 nil t nil | |
299 (or histvar 'eieio-read-class)))) | |
300 | |
301 ;;; METHOD COMPLETION / DOC | |
302 | |
303 (defalias 'describe-method 'eieio-describe-generic) | |
304 (defalias 'describe-generic 'eieio-describe-generic) | |
305 (defalias 'eieio-describe-method 'eieio-describe-generic) | |
306 | |
307 (defun eieio-describe-generic (generic) | |
308 "Describe the generic function GENERIC. | |
309 Also extracts information about all methods specific to this generic." | |
310 (interactive (list (eieio-read-generic "Generic Method: "))) | |
311 (if (not (generic-p generic)) | |
312 (signal 'wrong-type-argument '(generic-p generic))) | |
313 (with-output-to-temp-buffer (help-buffer) ; "*Help*" | |
105372
bd2966850aac
Use `called-interactively-p' instead of `interactive-p'.
Juanma Barranquero <lekktu@gmail.com>
parents:
105327
diff
changeset
|
314 (help-setup-xref (list #'eieio-describe-generic generic) |
bd2966850aac
Use `called-interactively-p' instead of `interactive-p'.
Juanma Barranquero <lekktu@gmail.com>
parents:
105327
diff
changeset
|
315 (called-interactively-p 'interactive)) |
105237 | 316 |
317 (prin1 generic) | |
318 (princ " is a generic function") | |
319 (when (generic-primary-only-p generic) | |
320 (princ " with only ") | |
321 (when (generic-primary-only-one-p generic) | |
322 (princ "one ")) | |
323 (princ "primary method") | |
324 (when (not (generic-primary-only-one-p generic)) | |
325 (princ "s")) | |
326 ) | |
327 (princ ".") | |
328 (terpri) | |
329 (terpri) | |
330 (let ((d (documentation generic))) | |
331 (if (not d) | |
332 (princ "The generic is not documented.\n") | |
333 (princ "Documentation:") | |
334 (terpri) | |
335 (princ d) | |
336 (terpri) | |
337 (terpri))) | |
338 (princ "Implementations:") | |
339 (terpri) | |
340 (terpri) | |
341 (let ((i 3) | |
342 (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) | |
343 ;; Loop over fanciful generics | |
344 (while (< i 6) | |
345 (let ((gm (aref (get generic 'eieio-method-tree) i))) | |
346 (when gm | |
347 (princ "Generic ") | |
348 (princ (aref prefix (- i 3))) | |
349 (terpri) | |
350 (princ (or (nth 2 gm) "Undocumented")) | |
351 (terpri) | |
352 (terpri))) | |
353 (setq i (1+ i))) | |
354 (setq i 0) | |
355 ;; Loop over defined class-specific methods | |
356 (while (< i 3) | |
357 (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))) | |
358 (while gm | |
359 (princ "`") | |
360 (prin1 (car (car gm))) | |
361 (princ "'") | |
362 ;; prefix type | |
363 (princ " ") | |
364 (princ (aref prefix i)) | |
365 (princ " ") | |
366 ;; argument list | |
367 (let* ((func (cdr (car gm))) | |
368 (arglst (eieio-lambda-arglist func))) | |
369 (prin1 arglst)) | |
370 (terpri) | |
371 ;; 3 because of cdr | |
372 (princ (or (documentation (cdr (car gm))) | |
373 "Undocumented")) | |
374 (setq gm (cdr gm)) | |
375 (terpri) | |
376 (terpri))) | |
377 (setq i (1+ i))))) | |
105813
df4934f25eef
* textmodes/two-column.el (2C-split):
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
105474
diff
changeset
|
378 (with-current-buffer (help-buffer) |
105237 | 379 (buffer-string))) |
380 | |
381 (defun eieio-lambda-arglist (func) | |
382 "Return the argument list of FUNC, a function body." | |
383 (if (symbolp func) (setq func (symbol-function func))) | |
384 (if (byte-code-function-p func) | |
385 (eieio-compiled-function-arglist func) | |
386 (car (cdr func)))) | |
387 | |
388 (defun eieio-all-generic-functions (&optional class) | |
389 "Return a list of all generic functions. | |
105474 | 390 Optional CLASS argument returns only those functions that contain |
391 methods for CLASS." | |
105237 | 392 (let ((l nil) tree (cn (if class (symbol-name class) nil))) |
393 (mapatoms | |
394 (lambda (symbol) | |
395 (setq tree (get symbol 'eieio-method-obarray)) | |
396 (if tree | |
397 (progn | |
398 ;; A symbol might be interned for that class in one of | |
399 ;; these three slots in the method-obarray. | |
400 (if (or (not class) | |
401 (fboundp (intern-soft cn (aref tree 0))) | |
402 (fboundp (intern-soft cn (aref tree 1))) | |
403 (fboundp (intern-soft cn (aref tree 2)))) | |
404 (setq l (cons symbol l))))))) | |
405 l)) | |
406 | |
407 (defun eieio-method-documentation (generic class) | |
408 "Return a list of the specific documentation of GENERIC for CLASS. | |
409 If there is not an explicit method for CLASS in GENERIC, or if that | |
410 function has no documentation, then return nil." | |
411 (let ((tree (get generic 'eieio-method-obarray)) | |
412 (cn (symbol-name class)) | |
413 before primary after) | |
414 (if (not tree) | |
415 nil | |
416 ;; A symbol might be interned for that class in one of | |
417 ;; these three slots in the method-obarray. | |
418 (setq before (intern-soft cn (aref tree 0)) | |
419 primary (intern-soft cn (aref tree 1)) | |
420 after (intern-soft cn (aref tree 2))) | |
421 (if (not (or (fboundp before) | |
422 (fboundp primary) | |
423 (fboundp after))) | |
424 nil | |
425 (list (if (fboundp before) | |
426 (cons (eieio-lambda-arglist before) | |
427 (documentation before)) | |
428 nil) | |
429 (if (fboundp primary) | |
430 (cons (eieio-lambda-arglist primary) | |
431 (documentation primary)) | |
432 nil) | |
433 (if (fboundp after) | |
434 (cons (eieio-lambda-arglist after) | |
435 (documentation after)) | |
436 nil)))))) | |
437 | |
438 (defvar eieio-read-generic nil | |
439 "History of the `eieio-read-generic' prompt.") | |
440 | |
441 (defun eieio-read-generic-p (fn) | |
442 "Function used in function `eieio-read-generic'. | |
443 This is because `generic-p' is a macro. | |
444 Argument FN is the function to test." | |
445 (generic-p fn)) | |
446 | |
447 (defun eieio-read-generic (prompt &optional historyvar) | |
448 "Read a generic function from the minibuffer with PROMPT. | |
449 Optional argument HISTORYVAR is the variable to use as history." | |
450 (intern (completing-read prompt obarray 'eieio-read-generic-p | |
451 t nil (or historyvar 'eieio-read-generic)))) | |
452 | |
453 ;;; METHOD STATS | |
454 ;; | |
455 ;; Dump out statistics about all the active methods in a session. | |
456 (defun eieio-display-method-list () | |
457 "Display a list of all the methods and what features are used." | |
458 (interactive) | |
459 (let* ((meth1 (eieio-all-generic-functions)) | |
460 (meth (sort meth1 (lambda (a b) | |
461 (string< (symbol-name a) | |
462 (symbol-name b))))) | |
463 (buff (get-buffer-create "*EIEIO Method List*")) | |
464 (methidx 0) | |
465 (standard-output buff) | |
466 (slots '(method-static | |
467 method-before | |
468 method-primary | |
469 method-after | |
470 method-generic-before | |
471 method-generic-primary | |
472 method-generic-after)) | |
473 (slotn '("static" | |
474 "before" | |
475 "primary" | |
476 "after" | |
477 "G bef" | |
478 "G prim" | |
479 "G aft")) | |
480 (idxarray (make-vector (length slots) 0)) | |
481 (primaryonly 0) | |
482 (oneprimary 0) | |
483 ) | |
484 (switch-to-buffer-other-window buff) | |
485 (erase-buffer) | |
486 (dolist (S slotn) | |
487 (princ S) | |
488 (princ "\t") | |
489 ) | |
490 (princ "Method Name") | |
491 (terpri) | |
492 (princ "--------------------------------------------------------------------") | |
493 (terpri) | |
494 (dolist (M meth) | |
495 (let ((mtree (get M 'eieio-method-tree)) | |
496 (P nil) (numP) | |
497 (!P nil)) | |
498 (dolist (S slots) | |
499 (let ((num (length (aref mtree (symbol-value S))))) | |
500 (aset idxarray (symbol-value S) | |
501 (+ num (aref idxarray (symbol-value S)))) | |
502 (prin1 num) | |
503 (princ "\t") | |
504 (when (< 0 num) | |
505 (if (eq S 'method-primary) | |
506 (setq P t numP num) | |
507 (setq !P t))) | |
508 )) | |
509 ;; Is this a primary-only impl method? | |
510 (when (and P (not !P)) | |
511 (setq primaryonly (1+ primaryonly)) | |
512 (when (= numP 1) | |
513 (setq oneprimary (1+ oneprimary)) | |
514 (princ "*")) | |
515 (princ "* ") | |
516 ) | |
517 (prin1 M) | |
518 (terpri) | |
519 (setq methidx (1+ methidx)) | |
520 ) | |
521 ) | |
522 (princ "--------------------------------------------------------------------") | |
523 (terpri) | |
524 (dolist (S slots) | |
525 (prin1 (aref idxarray (symbol-value S))) | |
526 (princ "\t") | |
527 ) | |
528 (prin1 methidx) | |
529 (princ " Total symbols") | |
530 (terpri) | |
531 (dolist (S slotn) | |
532 (princ S) | |
533 (princ "\t") | |
534 ) | |
535 (terpri) | |
536 (terpri) | |
537 (princ "Methods Primary Only: ") | |
538 (prin1 primaryonly) | |
539 (princ "\t") | |
540 (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100))) | |
541 (princ "% of total methods") | |
542 (terpri) | |
543 (princ "Only One Primary Impl: ") | |
544 (prin1 oneprimary) | |
545 (princ "\t") | |
546 (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100))) | |
547 (princ "% of total primary methods") | |
548 (terpri) | |
549 )) | |
550 | |
551 ;;; HELP AUGMENTATION | |
552 ;; | |
553 (defun eieio-help-mode-augmentation-maybee (&rest unused) | |
105474 | 554 "For buffers thrown into help mode, augment for EIEIO. |
105237 | 555 Arguments UNUSED are not used." |
556 ;; Scan created buttons so far if we are in help mode. | |
557 (when (eq major-mode 'help-mode) | |
558 (save-excursion | |
559 (goto-char (point-min)) | |
560 (let ((pos t) (inhibit-read-only t)) | |
561 (while pos | |
562 (if (get-text-property (point) 'help-xref) ; move off reference | |
563 (goto-char | |
564 (or (next-single-property-change (point) 'help-xref) | |
565 (point)))) | |
566 (setq pos (next-single-property-change (point) 'help-xref)) | |
567 (when pos | |
568 (goto-char pos) | |
569 (let* ((help-data (get-text-property (point) 'help-xref)) | |
570 ;(method (car help-data)) | |
571 (args (cdr help-data))) | |
572 (when (symbolp (car args)) | |
573 (cond ((class-p (car args)) | |
574 (setcar help-data 'eieio-describe-class)) | |
575 ((generic-p (car args)) | |
576 (setcar help-data 'eieio-describe-generic)) | |
577 (t nil)) | |
578 )))) | |
579 ;; start back at the beginning, and highlight some sections | |
580 (goto-char (point-min)) | |
581 (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t) | |
582 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
583 (goto-char (point-min)) | |
584 (if (re-search-forward "^Specialized Methods:$" nil t) | |
585 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
586 (goto-char (point-min)) | |
587 (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t) | |
588 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
589 (goto-char (point-min)) | |
590 (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t) | |
591 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
592 (goto-char (point-min)) | |
593 (while (re-search-forward "^\\(Private \\)?Slot:" nil t) | |
594 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) | |
595 )))) | |
596 | |
597 ;;; SPEEDBAR SUPPORT | |
598 ;; | |
599 (eval-when-compile | |
600 (condition-case nil | |
601 (require 'speedbar) | |
105474 | 602 (error (message "Error loading speedbar... ignored")))) |
105237 | 603 |
604 (defvar eieio-class-speedbar-key-map nil | |
605 "Keymap used when working with a project in speedbar.") | |
606 | |
607 (defun eieio-class-speedbar-make-map () | |
105474 | 608 "Make a keymap for EIEIO under speedbar." |
105237 | 609 (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap)) |
610 | |
611 ;; General viewing stuff | |
612 (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line) | |
613 (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line) | |
614 (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line) | |
615 ) | |
616 | |
617 (if eieio-class-speedbar-key-map | |
618 nil | |
619 (if (not (featurep 'speedbar)) | |
620 (add-hook 'speedbar-load-hook (lambda () | |
621 (eieio-class-speedbar-make-map) | |
622 (speedbar-add-expansion-list | |
623 '("EIEIO" | |
624 eieio-class-speedbar-menu | |
625 eieio-class-speedbar-key-map | |
626 eieio-class-speedbar)))) | |
627 (eieio-class-speedbar-make-map) | |
628 (speedbar-add-expansion-list '("EIEIO" | |
629 eieio-class-speedbar-menu | |
630 eieio-class-speedbar-key-map | |
631 eieio-class-speedbar)))) | |
632 | |
633 (defvar eieio-class-speedbar-menu | |
634 () | |
635 "Menu part in easymenu format used in speedbar while in `eieio' mode.") | |
636 | |
637 (defun eieio-class-speedbar (dir-or-object depth) | |
638 "Create buttons in speedbar that represents the current project. | |
105474 | 639 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the |
640 current expansion depth." | |
105237 | 641 (when (eq (point-min) (point-max)) |
642 ;; This function is only called once, to start the whole deal. | |
643 ;; Ceate, and expand the default object. | |
644 (eieio-class-button eieio-default-superclass 0) | |
645 (forward-line -1) | |
646 (speedbar-expand-line))) | |
647 | |
648 (defun eieio-class-button (class depth) | |
649 "Draw a speedbar button at the current point for CLASS at DEPTH." | |
650 (if (not (class-p class)) | |
651 (signal 'wrong-type-argument (list 'class-p class))) | |
652 (let ((subclasses (aref (class-v class) class-children))) | |
653 (if subclasses | |
654 (speedbar-make-tag-line 'angle ?+ | |
655 'eieio-sb-expand | |
656 class | |
657 (symbol-name class) | |
658 'eieio-describe-class-sb | |
659 class | |
660 'speedbar-directory-face | |
661 depth) | |
662 (speedbar-make-tag-line 'angle ? nil nil | |
663 (symbol-name class) | |
664 'eieio-describe-class-sb | |
665 class | |
666 'speedbar-directory-face | |
667 depth)))) | |
668 | |
669 (defun eieio-sb-expand (text class indent) | |
670 "For button TEXT, expand CLASS at the current location. | |
671 Argument INDENT is the depth of indentation." | |
672 (cond ((string-match "+" text) ;we have to expand this file | |
673 (speedbar-change-expand-button-char ?-) | |
674 (speedbar-with-writable | |
675 (save-excursion | |
676 (end-of-line) (forward-char 1) | |
677 (let ((subclasses (aref (class-v class) class-children))) | |
678 (while subclasses | |
679 (eieio-class-button (car subclasses) (1+ indent)) | |
680 (setq subclasses (cdr subclasses))))))) | |
681 ((string-match "-" text) ;we have to contract this node | |
682 (speedbar-change-expand-button-char ?+) | |
683 (speedbar-delete-subblock indent)) | |
684 (t (error "Ooops... not sure what to do"))) | |
685 (speedbar-center-buffer-smartly)) | |
686 | |
687 (defun eieio-describe-class-sb (text token indent) | |
688 "Describe the class TEXT in TOKEN. | |
689 INDENT is the current indentation level." | |
690 (speedbar-with-attached-buffer | |
691 (eieio-describe-class token)) | |
692 (speedbar-maybee-jump-to-attached-frame)) | |
693 | |
694 (provide 'eieio-opt) | |
695 | |
105377 | 696 ;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6 |
105237 | 697 ;;; eieio-opt.el ends here |