Commit | Line | Data |
---|---|---|
6dd12ef2 CY |
1 | ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) |
2 | ||
ba318903 | 3 | ;; Copyright (C) 1996, 1998-2003, 2005, 2008-2014 Free Software |
ab422c4d | 4 | ;; Foundation, Inc. |
6dd12ef2 | 5 | |
9ffe3f52 | 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
6dd12ef2 | 7 | ;; Keywords: OO, lisp |
bd78fa1d | 8 | ;; Package: eieio |
6dd12ef2 CY |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
14 | ;; the Free Software Foundation, either version 3 of the License, or | |
15 | ;; (at your option) any later version. | |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | ||
25 | ;;; Commentary: | |
26 | ;; | |
27 | ;; This contains support functions to eieio. These functions contain | |
28 | ;; some small class browser and class printing functions. | |
29 | ;; | |
30 | ||
31 | (require 'eieio) | |
62a81506 | 32 | (require 'find-func) |
3f2a848d DE |
33 | (require 'speedbar) |
34 | (require 'help-mode) | |
6dd12ef2 CY |
35 | |
36 | ;;; Code: | |
002b46b7 | 37 | ;;;###autoload |
6dd12ef2 CY |
38 | (defun eieio-browse (&optional root-class) |
39 | "Create an object browser window to show all objects. | |
40 | If optional ROOT-CLASS, then start with that, otherwise start with | |
41 | variable `eieio-default-superclass'." | |
42 | (interactive (if current-prefix-arg | |
43 | (list (read (completing-read "Class: " | |
44 | (eieio-build-class-alist) | |
45 | nil t))) | |
46 | nil)) | |
47 | (if (not root-class) (setq root-class 'eieio-default-superclass)) | |
8ca4f1e0 | 48 | (eieio--check-type class-p root-class) |
6dd12ef2 | 49 | (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) |
9a529312 | 50 | (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") |
6dd12ef2 CY |
51 | (erase-buffer) |
52 | (goto-char 0) | |
53 | (eieio-browse-tree root-class "" "") | |
54 | )) | |
55 | ||
56 | (defun eieio-browse-tree (this-root prefix ch-prefix) | |
a8f316ca | 57 | "Recursively draw the children of the given class on the screen. |
6dd12ef2 CY |
58 | Argument THIS-ROOT is the local root of the tree. |
59 | Argument PREFIX is the character prefix to use. | |
60 | Argument CH-PREFIX is another character prefix to display." | |
8ca4f1e0 | 61 | (eieio--check-type class-p this-root) |
6dd12ef2 | 62 | (let ((myname (symbol-name this-root)) |
8ca4f1e0 | 63 | (chl (eieio--class-children (class-v this-root))) |
6dd12ef2 CY |
64 | (fprefix (concat ch-prefix " +--")) |
65 | (mprefix (concat ch-prefix " | ")) | |
66 | (lprefix (concat ch-prefix " "))) | |
67 | (insert prefix myname "\n") | |
68 | (while (cdr chl) | |
69 | (eieio-browse-tree (car chl) fprefix mprefix) | |
70 | (setq chl (cdr chl))) | |
71 | (if chl | |
72 | (eieio-browse-tree (car chl) fprefix lprefix)) | |
73 | )) | |
74 | ||
75 | ;;; CLASS COMPLETION / DOCUMENTATION | |
76 | ||
002b46b7 | 77 | ;;;###autoload |
0f918d96 DE |
78 | (defun eieio-help-class (class) |
79 | "Print help description for CLASS. | |
80 | If CLASS is actually an object, then also display current values of that object." | |
81 | ;; Header line | |
82 | (prin1 class) | |
83 | (insert " is a" | |
84 | (if (class-option class :abstract) | |
85 | "n abstract" | |
86 | "") | |
87 | " class") | |
88 | (let ((location (get class 'class-location))) | |
89 | (when location | |
90 | (insert " in `") | |
91 | (help-insert-xref-button | |
92 | (file-name-nondirectory location) | |
93 | 'eieio-class-def class location) | |
94 | (insert "'"))) | |
95 | (insert ".\n") | |
96 | ;; Parents | |
97 | (let ((pl (eieio-class-parents class)) | |
98 | cur) | |
99 | (when pl | |
100 | (insert " Inherits from ") | |
101 | (while (setq cur (pop pl)) | |
102 | (insert "`") | |
103 | (help-insert-xref-button (symbol-name cur) | |
104 | 'help-function cur) | |
105 | (insert (if pl "', " "'"))) | |
106 | (insert ".\n"))) | |
107 | ;; Children | |
108 | (let ((ch (eieio-class-children class)) | |
109 | cur) | |
110 | (when ch | |
111 | (insert " Children ") | |
112 | (while (setq cur (pop ch)) | |
113 | (insert "`") | |
114 | (help-insert-xref-button (symbol-name cur) | |
115 | 'help-function cur) | |
116 | (insert (if ch "', " "'"))) | |
117 | (insert ".\n"))) | |
118 | ;; System documentation | |
119 | (let ((doc (documentation-property class 'variable-documentation))) | |
120 | (when doc | |
121 | (insert "\n" doc "\n\n"))) | |
122 | ;; Describe all the slots in this class. | |
123 | (eieio-help-class-slots class) | |
124 | ;; Describe all the methods specific to this class. | |
125 | (let ((methods (eieio-all-generic-functions class)) | |
126 | (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"]) | |
06827ec8 | 127 | counter doc) |
0f918d96 DE |
128 | (when methods |
129 | (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) | |
130 | (while methods | |
131 | (setq doc (eieio-method-documentation (car methods) class)) | |
132 | (insert "`") | |
133 | (help-insert-xref-button (symbol-name (car methods)) | |
134 | 'help-function (car methods)) | |
135 | (insert "'") | |
136 | (if (not doc) | |
137 | (insert " Undocumented") | |
138 | (setq counter 0) | |
139 | (dolist (cur doc) | |
140 | (when cur | |
141 | (insert " " (aref type counter) " " | |
142 | (prin1-to-string (car cur) (current-buffer)) | |
143 | "\n" | |
ec264fbb | 144 | (or (cdr cur) ""))) |
0f918d96 DE |
145 | (setq counter (1+ counter)))) |
146 | (insert "\n\n") | |
147 | (setq methods (cdr methods)))))) | |
148 | ||
149 | (defun eieio-help-class-slots (class) | |
150 | "Print help description for the slots in CLASS. | |
151 | Outputs to the current buffer." | |
6dd12ef2 | 152 | (let* ((cv (class-v class)) |
8ca4f1e0 SM |
153 | (docs (eieio--class-public-doc cv)) |
154 | (names (eieio--class-public-a cv)) | |
155 | (deflt (eieio--class-public-d cv)) | |
156 | (types (eieio--class-public-type cv)) | |
157 | (publp (eieio--class-public-printer cv)) | |
6dd12ef2 | 158 | (i 0) |
8ca4f1e0 | 159 | (prot (eieio--class-protection cv)) |
6dd12ef2 | 160 | ) |
0f918d96 DE |
161 | (insert (propertize "Instance Allocated Slots:\n\n" |
162 | 'face 'bold)) | |
6dd12ef2 | 163 | (while names |
0f918d96 DE |
164 | (insert |
165 | (concat | |
166 | (when (car prot) | |
167 | (propertize "Private " 'face 'bold)) | |
168 | (propertize "Slot: " 'face 'bold) | |
169 | (prin1-to-string (car names)) | |
170 | (unless (eq (aref types i) t) | |
171 | (concat " type = " | |
172 | (prin1-to-string (aref types i)))) | |
173 | (unless (eq (car deflt) eieio-unbound) | |
174 | (concat " default = " | |
175 | (prin1-to-string (car deflt)))) | |
176 | (when (car publp) | |
177 | (concat " printer = " | |
178 | (prin1-to-string (car publp)))) | |
179 | (when (car docs) | |
180 | (concat "\n " (car docs) "\n")) | |
181 | "\n")) | |
6dd12ef2 CY |
182 | (setq names (cdr names) |
183 | docs (cdr docs) | |
184 | deflt (cdr deflt) | |
185 | publp (cdr publp) | |
186 | prot (cdr prot) | |
187 | i (1+ i))) | |
8ca4f1e0 SM |
188 | (setq docs (eieio--class-class-allocation-doc cv) |
189 | names (eieio--class-class-allocation-a cv) | |
190 | types (eieio--class-class-allocation-type cv) | |
6dd12ef2 | 191 | i 0 |
8ca4f1e0 | 192 | prot (eieio--class-class-allocation-protection cv)) |
6dd12ef2 | 193 | (when names |
0f918d96 | 194 | (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) |
6dd12ef2 | 195 | (while names |
0f918d96 DE |
196 | (insert |
197 | (concat | |
198 | (when (car prot) | |
199 | "Private ") | |
200 | "Slot: " | |
201 | (prin1-to-string (car names)) | |
202 | (unless (eq (aref types i) t) | |
203 | (concat " type = " | |
204 | (prin1-to-string (aref types i)))) | |
205 | (condition-case nil | |
206 | (let ((value (eieio-oref class (car names)))) | |
207 | (concat " value = " | |
208 | (prin1-to-string value))) | |
6dd12ef2 | 209 | (error nil)) |
0f918d96 DE |
210 | (when (car docs) |
211 | (concat "\n\n " (car docs) "\n")) | |
212 | "\n")) | |
6dd12ef2 CY |
213 | (setq names (cdr names) |
214 | docs (cdr docs) | |
215 | prot (cdr prot) | |
216 | i (1+ i))))) | |
217 | ||
62a81506 CY |
218 | (defun eieio-build-class-list (class) |
219 | "Return a list of all classes that inherit from CLASS." | |
220 | (if (class-p class) | |
221 | (apply #'append | |
222 | (mapcar | |
223 | (lambda (c) | |
224 | (append (list c) (eieio-build-class-list c))) | |
8ca4f1e0 | 225 | (eieio-class-children-fast class))) |
62a81506 CY |
226 | (list class))) |
227 | ||
6dd12ef2 CY |
228 | (defun eieio-build-class-alist (&optional class instantiable-only buildlist) |
229 | "Return an alist of all currently active classes for completion purposes. | |
230 | Optional argument CLASS is the class to start with. | |
231 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
232 | are not abstract, otherwise allow all classes. | |
233 | Optional argument BUILDLIST is more list to attach and is used internally." | |
234 | (let* ((cc (or class eieio-default-superclass)) | |
8ca4f1e0 | 235 | (sublst (eieio--class-children (class-v cc)))) |
62a81506 CY |
236 | (unless (assoc (symbol-name cc) buildlist) |
237 | (when (or (not instantiable-only) (not (class-abstract-p cc))) | |
238 | (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) | |
6dd12ef2 CY |
239 | (while sublst |
240 | (setq buildlist (eieio-build-class-alist | |
241 | (car sublst) instantiable-only buildlist)) | |
242 | (setq sublst (cdr sublst))) | |
243 | buildlist)) | |
244 | ||
245 | (defvar eieio-read-class nil | |
246 | "History of the function `eieio-read-class' prompt.") | |
247 | ||
248 | (defun eieio-read-class (prompt &optional histvar instantiable-only) | |
249 | "Return a class chosen by the user using PROMPT. | |
250 | Optional argument HISTVAR is a variable to use as history. | |
251 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
252 | are not abstract." | |
253 | (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only) | |
254 | nil t nil | |
255 | (or histvar 'eieio-read-class)))) | |
256 | ||
257 | (defun eieio-read-subclass (prompt class &optional histvar instantiable-only) | |
258 | "Return a class chosen by the user using PROMPT. | |
259 | CLASS is the base class, and completion occurs across all subclasses. | |
260 | Optional argument HISTVAR is a variable to use as history. | |
261 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which | |
262 | are not abstract." | |
263 | (intern (completing-read prompt | |
264 | (eieio-build-class-alist class instantiable-only) | |
265 | nil t nil | |
266 | (or histvar 'eieio-read-class)))) | |
267 | ||
268 | ;;; METHOD COMPLETION / DOC | |
269 | ||
0f918d96 DE |
270 | (define-button-type 'eieio-method-def |
271 | :supertype 'help-xref | |
272 | 'help-function (lambda (class method file) | |
273 | (eieio-help-find-method-definition class method file)) | |
274 | 'help-echo (purecopy "mouse-2, RET: find method's definition")) | |
275 | ||
276 | (define-button-type 'eieio-class-def | |
277 | :supertype 'help-xref | |
278 | 'help-function (lambda (class file) | |
279 | (eieio-help-find-class-definition class file)) | |
280 | 'help-echo (purecopy "mouse-2, RET: find class definition")) | |
6dd12ef2 | 281 | |
002b46b7 | 282 | ;;;###autoload |
0f918d96 DE |
283 | (defun eieio-help-constructor (ctr) |
284 | "Describe CTR if it is a class constructor." | |
285 | (when (class-p ctr) | |
286 | (erase-buffer) | |
287 | (let ((location (get ctr 'class-location)) | |
288 | (def (symbol-function ctr))) | |
289 | (goto-char (point-min)) | |
290 | (prin1 ctr) | |
291 | (insert (format " is an %s object constructor function" | |
292 | (if (autoloadp def) | |
293 | "autoloaded" | |
294 | ""))) | |
295 | (when (and (autoloadp def) | |
296 | (null location)) | |
297 | (setq location | |
298 | (find-lisp-object-file-name ctr def))) | |
299 | (when location | |
300 | (insert " in `") | |
301 | (help-insert-xref-button | |
302 | (file-name-nondirectory location) | |
303 | 'eieio-class-def ctr location) | |
304 | (insert "'")) | |
305 | (insert ".\nCreates an object of class " (symbol-name ctr) ".") | |
306 | (goto-char (point-max)) | |
307 | (if (autoloadp def) | |
308 | (insert "\n\n[Class description not available until class definition is loaded.]\n") | |
309 | (save-excursion | |
310 | (insert (propertize "\n\nClass description:\n" 'face 'bold)) | |
311 | (eieio-help-class ctr)) | |
312 | )))) | |
313 | ||
314 | ||
315 | ;;;###autoload | |
316 | (defun eieio-help-generic (generic) | |
317 | "Describe GENERIC if it is a generic function." | |
566cb04b | 318 | (when (and (symbolp generic) (generic-p generic)) |
0f918d96 DE |
319 | (save-excursion |
320 | (goto-char (point-min)) | |
321 | (when (re-search-forward " in `.+'.$" nil t) | |
322 | (replace-match "."))) | |
323 | (save-excursion | |
324 | (insert "\n\nThis is a generic function" | |
325 | (cond | |
326 | ((and (generic-primary-only-p generic) | |
327 | (generic-primary-only-one-p generic)) | |
328 | " with only one primary method") | |
329 | ((generic-primary-only-p generic) | |
330 | " with only primary methods") | |
331 | (t "")) | |
332 | ".\n\n") | |
333 | (insert (propertize "Implementations:\n\n" 'face 'bold)) | |
334 | (let ((i 4) | |
335 | (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) | |
336 | ;; Loop over fanciful generics | |
337 | (while (< i 7) | |
338 | (let ((gm (aref (get generic 'eieio-method-tree) i))) | |
339 | (when gm | |
340 | (insert "Generic " | |
341 | (aref prefix (- i 3)) | |
342 | "\n" | |
343 | (or (nth 2 gm) "Undocumented") | |
344 | "\n\n"))) | |
345 | (setq i (1+ i))) | |
346 | (setq i 0) | |
347 | ;; Loop over defined class-specific methods | |
348 | (while (< i 4) | |
349 | (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i))) | |
350 | cname location) | |
351 | (while gm | |
352 | (setq cname (caar gm)) | |
353 | (insert "`") | |
354 | (help-insert-xref-button (symbol-name cname) | |
355 | 'help-variable cname) | |
356 | (insert "' " (aref prefix i) " ") | |
357 | ;; argument list | |
358 | (let* ((func (cdr (car gm))) | |
359 | (arglst (eieio-lambda-arglist func))) | |
360 | (prin1 arglst (current-buffer))) | |
361 | (insert "\n" | |
362 | (or (documentation (cdr (car gm))) | |
363 | "Undocumented")) | |
364 | ;; Print file location if available | |
365 | (when (and (setq location (get generic 'method-locations)) | |
366 | (setq location (assoc cname location))) | |
367 | (setq location (cadr location)) | |
368 | (insert "\n\nDefined in `") | |
369 | (help-insert-xref-button | |
370 | (file-name-nondirectory location) | |
371 | 'eieio-method-def cname generic location) | |
372 | (insert "'\n")) | |
373 | (setq gm (cdr gm)) | |
374 | (insert "\n"))) | |
375 | (setq i (1+ i))))))) | |
6dd12ef2 CY |
376 | |
377 | (defun eieio-lambda-arglist (func) | |
378 | "Return the argument list of FUNC, a function body." | |
379 | (if (symbolp func) (setq func (symbol-function func))) | |
380 | (if (byte-code-function-p func) | |
381 | (eieio-compiled-function-arglist func) | |
382 | (car (cdr func)))) | |
383 | ||
384 | (defun eieio-all-generic-functions (&optional class) | |
385 | "Return a list of all generic functions. | |
a8f316ca JB |
386 | Optional CLASS argument returns only those functions that contain |
387 | methods for CLASS." | |
6dd12ef2 CY |
388 | (let ((l nil) tree (cn (if class (symbol-name class) nil))) |
389 | (mapatoms | |
390 | (lambda (symbol) | |
391 | (setq tree (get symbol 'eieio-method-obarray)) | |
392 | (if tree | |
393 | (progn | |
394 | ;; A symbol might be interned for that class in one of | |
395 | ;; these three slots in the method-obarray. | |
396 | (if (or (not class) | |
397 | (fboundp (intern-soft cn (aref tree 0))) | |
398 | (fboundp (intern-soft cn (aref tree 1))) | |
399 | (fboundp (intern-soft cn (aref tree 2)))) | |
400 | (setq l (cons symbol l))))))) | |
401 | l)) | |
402 | ||
403 | (defun eieio-method-documentation (generic class) | |
404 | "Return a list of the specific documentation of GENERIC for CLASS. | |
405 | If there is not an explicit method for CLASS in GENERIC, or if that | |
406 | function has no documentation, then return nil." | |
407 | (let ((tree (get generic 'eieio-method-obarray)) | |
408 | (cn (symbol-name class)) | |
409 | before primary after) | |
410 | (if (not tree) | |
411 | nil | |
412 | ;; A symbol might be interned for that class in one of | |
413 | ;; these three slots in the method-obarray. | |
414 | (setq before (intern-soft cn (aref tree 0)) | |
415 | primary (intern-soft cn (aref tree 1)) | |
416 | after (intern-soft cn (aref tree 2))) | |
417 | (if (not (or (fboundp before) | |
418 | (fboundp primary) | |
419 | (fboundp after))) | |
420 | nil | |
421 | (list (if (fboundp before) | |
422 | (cons (eieio-lambda-arglist before) | |
423 | (documentation before)) | |
424 | nil) | |
425 | (if (fboundp primary) | |
426 | (cons (eieio-lambda-arglist primary) | |
427 | (documentation primary)) | |
428 | nil) | |
429 | (if (fboundp after) | |
430 | (cons (eieio-lambda-arglist after) | |
431 | (documentation after)) | |
432 | nil)))))) | |
433 | ||
434 | (defvar eieio-read-generic nil | |
435 | "History of the `eieio-read-generic' prompt.") | |
436 | ||
437 | (defun eieio-read-generic-p (fn) | |
438 | "Function used in function `eieio-read-generic'. | |
439 | This is because `generic-p' is a macro. | |
440 | Argument FN is the function to test." | |
441 | (generic-p fn)) | |
442 | ||
443 | (defun eieio-read-generic (prompt &optional historyvar) | |
444 | "Read a generic function from the minibuffer with PROMPT. | |
445 | Optional argument HISTORYVAR is the variable to use as history." | |
446 | (intern (completing-read prompt obarray 'eieio-read-generic-p | |
447 | t nil (or historyvar 'eieio-read-generic)))) | |
448 | ||
449 | ;;; METHOD STATS | |
450 | ;; | |
451 | ;; Dump out statistics about all the active methods in a session. | |
452 | (defun eieio-display-method-list () | |
453 | "Display a list of all the methods and what features are used." | |
454 | (interactive) | |
455 | (let* ((meth1 (eieio-all-generic-functions)) | |
456 | (meth (sort meth1 (lambda (a b) | |
457 | (string< (symbol-name a) | |
458 | (symbol-name b))))) | |
459 | (buff (get-buffer-create "*EIEIO Method List*")) | |
460 | (methidx 0) | |
461 | (standard-output buff) | |
462 | (slots '(method-static | |
463 | method-before | |
464 | method-primary | |
465 | method-after | |
466 | method-generic-before | |
467 | method-generic-primary | |
468 | method-generic-after)) | |
469 | (slotn '("static" | |
470 | "before" | |
471 | "primary" | |
472 | "after" | |
473 | "G bef" | |
474 | "G prim" | |
475 | "G aft")) | |
476 | (idxarray (make-vector (length slots) 0)) | |
477 | (primaryonly 0) | |
478 | (oneprimary 0) | |
479 | ) | |
480 | (switch-to-buffer-other-window buff) | |
481 | (erase-buffer) | |
482 | (dolist (S slotn) | |
483 | (princ S) | |
484 | (princ "\t") | |
485 | ) | |
486 | (princ "Method Name") | |
487 | (terpri) | |
488 | (princ "--------------------------------------------------------------------") | |
489 | (terpri) | |
490 | (dolist (M meth) | |
491 | (let ((mtree (get M 'eieio-method-tree)) | |
492 | (P nil) (numP) | |
493 | (!P nil)) | |
494 | (dolist (S slots) | |
495 | (let ((num (length (aref mtree (symbol-value S))))) | |
496 | (aset idxarray (symbol-value S) | |
497 | (+ num (aref idxarray (symbol-value S)))) | |
498 | (prin1 num) | |
499 | (princ "\t") | |
500 | (when (< 0 num) | |
501 | (if (eq S 'method-primary) | |
502 | (setq P t numP num) | |
503 | (setq !P t))) | |
504 | )) | |
505 | ;; Is this a primary-only impl method? | |
506 | (when (and P (not !P)) | |
507 | (setq primaryonly (1+ primaryonly)) | |
508 | (when (= numP 1) | |
509 | (setq oneprimary (1+ oneprimary)) | |
510 | (princ "*")) | |
511 | (princ "* ") | |
512 | ) | |
513 | (prin1 M) | |
514 | (terpri) | |
515 | (setq methidx (1+ methidx)) | |
516 | ) | |
517 | ) | |
518 | (princ "--------------------------------------------------------------------") | |
519 | (terpri) | |
520 | (dolist (S slots) | |
521 | (prin1 (aref idxarray (symbol-value S))) | |
522 | (princ "\t") | |
523 | ) | |
524 | (prin1 methidx) | |
525 | (princ " Total symbols") | |
526 | (terpri) | |
527 | (dolist (S slotn) | |
528 | (princ S) | |
529 | (princ "\t") | |
530 | ) | |
531 | (terpri) | |
532 | (terpri) | |
533 | (princ "Methods Primary Only: ") | |
534 | (prin1 primaryonly) | |
535 | (princ "\t") | |
536 | (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100))) | |
537 | (princ "% of total methods") | |
538 | (terpri) | |
539 | (princ "Only One Primary Impl: ") | |
540 | (prin1 oneprimary) | |
541 | (princ "\t") | |
542 | (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100))) | |
543 | (princ "% of total primary methods") | |
544 | (terpri) | |
545 | )) | |
546 | ||
547 | ;;; HELP AUGMENTATION | |
548 | ;; | |
62a81506 CY |
549 | (defun eieio-help-find-method-definition (class method file) |
550 | (let ((filename (find-library-name file)) | |
551 | location buf) | |
0f918d96 DE |
552 | (when (symbolp class) |
553 | (setq class (symbol-name class))) | |
554 | (when (symbolp method) | |
555 | (setq method (symbol-name method))) | |
62a81506 CY |
556 | (when (null filename) |
557 | (error "Cannot find library %s" file)) | |
558 | (setq buf (find-file-noselect filename)) | |
559 | (with-current-buffer buf | |
560 | (goto-char (point-min)) | |
561 | (when | |
562 | (re-search-forward | |
563 | ;; Regexp for searching methods. | |
564 | (concat "(defmethod[ \t\r\n]+" method | |
565 | "\\([ \t\r\n]+:[a-zA-Z]+\\)?" | |
566 | "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" | |
567 | class | |
568 | "\\s-*)") | |
569 | nil t) | |
570 | (setq location (match-beginning 0)))) | |
571 | (if (null location) | |
572 | (message "Unable to find location in file") | |
573 | (pop-to-buffer buf) | |
574 | (goto-char location) | |
575 | (recenter) | |
576 | (beginning-of-line)))) | |
577 | ||
578 | (defun eieio-help-find-class-definition (class file) | |
0f918d96 DE |
579 | (when (symbolp class) |
580 | (setq class (symbol-name class))) | |
62a81506 CY |
581 | (let ((filename (find-library-name file)) |
582 | location buf) | |
583 | (when (null filename) | |
584 | (error "Cannot find library %s" file)) | |
585 | (setq buf (find-file-noselect filename)) | |
586 | (with-current-buffer buf | |
587 | (goto-char (point-min)) | |
588 | (when | |
589 | (re-search-forward | |
590 | ;; Regexp for searching a class. | |
591 | (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") | |
592 | nil t) | |
593 | (setq location (match-beginning 0)))) | |
594 | (if (null location) | |
595 | (message "Unable to find location in file") | |
596 | (pop-to-buffer buf) | |
597 | (goto-char location) | |
598 | (recenter) | |
599 | (beginning-of-line)))) | |
600 | ||
6dd12ef2 CY |
601 | ;;; SPEEDBAR SUPPORT |
602 | ;; | |
6dd12ef2 CY |
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 () | |
a8f316ca | 608 | "Make a keymap for EIEIO under speedbar." |
6dd12ef2 CY |
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. | |
a8f316ca JB |
639 | DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the |
640 | current expansion depth." | |
6dd12ef2 CY |
641 | (when (eq (point-min) (point-max)) |
642 | ;; This function is only called once, to start the whole deal. | |
d5081c1e | 643 | ;; Create and expand the default object. |
6dd12ef2 CY |
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." | |
8ca4f1e0 SM |
650 | (eieio--check-type class-p class) |
651 | (let ((subclasses (eieio--class-children (class-v class)))) | |
6dd12ef2 CY |
652 | (if subclasses |
653 | (speedbar-make-tag-line 'angle ?+ | |
654 | 'eieio-sb-expand | |
655 | class | |
656 | (symbol-name class) | |
657 | 'eieio-describe-class-sb | |
658 | class | |
659 | 'speedbar-directory-face | |
660 | depth) | |
661 | (speedbar-make-tag-line 'angle ? nil nil | |
662 | (symbol-name class) | |
663 | 'eieio-describe-class-sb | |
664 | class | |
665 | 'speedbar-directory-face | |
666 | depth)))) | |
667 | ||
668 | (defun eieio-sb-expand (text class indent) | |
669 | "For button TEXT, expand CLASS at the current location. | |
670 | Argument INDENT is the depth of indentation." | |
671 | (cond ((string-match "+" text) ;we have to expand this file | |
672 | (speedbar-change-expand-button-char ?-) | |
673 | (speedbar-with-writable | |
674 | (save-excursion | |
675 | (end-of-line) (forward-char 1) | |
8ca4f1e0 | 676 | (let ((subclasses (eieio--class-children (class-v class)))) |
6dd12ef2 CY |
677 | (while subclasses |
678 | (eieio-class-button (car subclasses) (1+ indent)) | |
679 | (setq subclasses (cdr subclasses))))))) | |
680 | ((string-match "-" text) ;we have to contract this node | |
681 | (speedbar-change-expand-button-char ?+) | |
682 | (speedbar-delete-subblock indent)) | |
683 | (t (error "Ooops... not sure what to do"))) | |
684 | (speedbar-center-buffer-smartly)) | |
685 | ||
686 | (defun eieio-describe-class-sb (text token indent) | |
687 | "Describe the class TEXT in TOKEN. | |
688 | INDENT is the current indentation level." | |
0cdffd7d | 689 | (dframe-with-attached-buffer |
0f918d96 | 690 | (describe-function token)) |
0cdffd7d | 691 | (dframe-maybee-jump-to-attached-frame)) |
6dd12ef2 CY |
692 | |
693 | (provide 'eieio-opt) | |
694 | ||
05e0afce DE |
695 | ;; Local variables: |
696 | ;; generated-autoload-file: "eieio.el" | |
697 | ;; End: | |
698 | ||
6dd12ef2 | 699 | ;;; eieio-opt.el ends here |