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