Mercurial > emacs
annotate lisp/cedet/data-debug.el @ 109351:c8a969d13eda
merge trunk
author | Kenichi Handa <handa@etlken> |
---|---|
date | Fri, 09 Jul 2010 15:55:27 +0900 |
parents | f6b8c73548b3 |
children | 280c8ae2476d 376148b31b5e |
rev | line source |
---|---|
105241 | 1 ;;; data-debug.el --- Datastructure Debugger |
2 | |
106815 | 3 ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
105241 | 4 |
5 ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
6 ;; Version: 0.2 | |
7 ;; Keywords: OO, lisp | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation, either version 3 of the License, or | |
14 ;; (at your option) any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | |
24 ;;; Commentary: | |
25 ;; | |
26 ;; Provide a simple way to investigate particularly large and complex | |
27 ;; data structures. | |
28 ;; | |
29 ;; The best way to get started is to bind M-: to 'data-debug-eval-expression. | |
30 ;; | |
31 ;; (global-set-key "\M-:" 'data-debug-eval-expression) | |
32 ;; | |
33 ;; If you write functions with complex output that need debugging, you | |
34 ;; can make them interactive with data-debug-show-stuff. For example: | |
35 ;; | |
36 ;; (defun my-complex-output-fcn () | |
37 ;; "Calculate something complicated at point, and return it." | |
38 ;; (interactive) ;; function not normally interactive | |
39 ;; (let ((stuff (do-stuff))) | |
40 ;; (when (interactive-p) | |
41 ;; (data-debug-show-stuff stuff "myStuff")) | |
42 ;; stuff)) | |
43 | |
44 (require 'font-lock) | |
45 (require 'ring) | |
46 | |
47 ;;; Code: | |
48 | |
49 ;;; Compatibility | |
50 ;; | |
51 (if (featurep 'xemacs) | |
52 (eval-and-compile | |
53 (defalias 'data-debug-overlay-properties 'extent-properties) | |
54 (defalias 'data-debug-overlay-p 'extentp) | |
55 (if (not (fboundp 'propertize)) | |
56 (defun dd-propertize (string &rest properties) | |
57 "Mimic 'propertize' in from Emacs 23." | |
58 (add-text-properties 0 (length string) properties string) | |
59 string | |
60 ) | |
61 (defalias 'dd-propertize 'propertize)) | |
62 ) | |
63 ;; Regular Emacs | |
64 (eval-and-compile | |
65 (defalias 'data-debug-overlay-properties 'overlay-properties) | |
66 (defalias 'data-debug-overlay-p 'overlayp) | |
67 (defalias 'dd-propertize 'propertize) | |
68 ) | |
69 ) | |
70 | |
71 ;;; GENERIC STUFF | |
72 ;; | |
73 (defun data-debug-insert-property-list (proplist prefix &optional parent) | |
74 "Insert the property list PROPLIST. | |
75 Each line starts with PREFIX. | |
76 The attributes belong to the tag PARENT." | |
77 (while proplist | |
78 (let ((pretext (concat (symbol-name (car proplist)) " : "))) | |
79 (data-debug-insert-thing (car (cdr proplist)) | |
80 prefix | |
81 pretext | |
82 parent)) | |
83 (setq proplist (cdr (cdr proplist))))) | |
84 | |
85 ;;; overlays | |
86 ;; | |
87 (defun data-debug-insert-overlay-props (overlay prefix) | |
88 "Insert all the parts of OVERLAY. | |
89 PREFIX specifies what to insert at the start of each line." | |
90 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) | |
91 (proplist (data-debug-overlay-properties overlay))) | |
92 (data-debug-insert-property-list | |
93 proplist attrprefix) | |
94 ) | |
95 ) | |
96 | |
97 (defun data-debug-insert-overlay-from-point (point) | |
98 "Insert the overlay found at the overlay button at POINT." | |
99 (let ((overlay (get-text-property point 'ddebug)) | |
100 (indent (get-text-property point 'ddebug-indent)) | |
101 start | |
102 ) | |
103 (end-of-line) | |
104 (setq start (point)) | |
105 (forward-char 1) | |
106 (data-debug-insert-overlay-props overlay | |
107 (concat (make-string indent ? ) | |
108 "| ")) | |
109 (goto-char start) | |
110 )) | |
111 | |
112 (defun data-debug-insert-overlay-button (overlay prefix prebuttontext) | |
113 "Insert a button representing OVERLAY. | |
105325 | 114 PREFIX is the text that precedes the button. |
105241 | 115 PREBUTTONTEXT is some text between prefix and the overlay button." |
116 (let ((start (point)) | |
117 (end nil) | |
118 (str (format "%s" overlay)) | |
119 (tip nil)) | |
120 (insert prefix prebuttontext str) | |
121 (setq end (point)) | |
122 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
123 (put-text-property start end 'ddebug overlay) | |
124 (put-text-property start end 'ddebug-indent(length prefix)) | |
125 (put-text-property start end 'ddebug-prefix prefix) | |
126 (put-text-property start end 'help-echo tip) | |
127 (put-text-property start end 'ddebug-function | |
128 'data-debug-insert-overlay-from-point) | |
129 (insert "\n") | |
130 ) | |
131 ) | |
132 | |
133 ;;; overlay list | |
134 ;; | |
135 (defun data-debug-insert-overlay-list (overlaylist prefix) | |
136 "Insert all the parts of OVERLAYLIST. | |
137 PREFIX specifies what to insert at the start of each line." | |
138 (while overlaylist | |
139 (data-debug-insert-overlay-button (car overlaylist) | |
140 prefix | |
141 "") | |
142 (setq overlaylist (cdr overlaylist)))) | |
143 | |
144 (defun data-debug-insert-overlay-list-from-point (point) | |
145 "Insert the overlay found at the overlay list button at POINT." | |
146 (let ((overlaylist (get-text-property point 'ddebug)) | |
147 (indent (get-text-property point 'ddebug-indent)) | |
148 start | |
149 ) | |
150 (end-of-line) | |
151 (setq start (point)) | |
152 (forward-char 1) | |
153 (data-debug-insert-overlay-list overlaylist | |
154 (concat (make-string indent ? ) | |
155 "* ")) | |
156 (goto-char start) | |
157 )) | |
158 | |
159 (defun data-debug-insert-overlay-list-button (overlaylist | |
160 prefix | |
161 prebuttontext) | |
162 "Insert a button representing OVERLAYLIST. | |
105325 | 163 PREFIX is the text that precedes the button. |
105241 | 164 PREBUTTONTEXT is some text between prefix and the overlay list button." |
165 (let ((start (point)) | |
166 (end nil) | |
167 (str (format "#<overlay list: %d entries>" (length overlaylist))) | |
168 (tip nil)) | |
169 (insert prefix prebuttontext str) | |
170 (setq end (point)) | |
171 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
172 (put-text-property start end 'ddebug overlaylist) | |
173 (put-text-property start end 'ddebug-indent(length prefix)) | |
174 (put-text-property start end 'ddebug-prefix prefix) | |
175 (put-text-property start end 'help-echo tip) | |
176 (put-text-property start end 'ddebug-function | |
177 'data-debug-insert-overlay-list-from-point) | |
178 (insert "\n") | |
179 ) | |
180 ) | |
181 | |
182 ;;; buffers | |
183 ;; | |
184 (defun data-debug-insert-buffer-props (buffer prefix) | |
185 "Insert all the parts of BUFFER. | |
186 PREFIX specifies what to insert at the start of each line." | |
187 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) | |
188 (proplist | |
189 (list :filename (buffer-file-name buffer) | |
190 :live (buffer-live-p buffer) | |
191 :modified (buffer-modified-p buffer) | |
192 :size (buffer-size buffer) | |
193 :process (get-buffer-process buffer) | |
194 :localvars (buffer-local-variables buffer) | |
195 ))) | |
196 (data-debug-insert-property-list | |
197 proplist attrprefix) | |
198 ) | |
199 ) | |
200 | |
201 (defun data-debug-insert-buffer-from-point (point) | |
202 "Insert the buffer found at the buffer button at POINT." | |
203 (let ((buffer (get-text-property point 'ddebug)) | |
204 (indent (get-text-property point 'ddebug-indent)) | |
205 start | |
206 ) | |
207 (end-of-line) | |
208 (setq start (point)) | |
209 (forward-char 1) | |
210 (data-debug-insert-buffer-props buffer | |
211 (concat (make-string indent ? ) | |
212 "| ")) | |
213 (goto-char start) | |
214 )) | |
215 | |
216 (defun data-debug-insert-buffer-button (buffer prefix prebuttontext) | |
217 "Insert a button representing BUFFER. | |
105325 | 218 PREFIX is the text that precedes the button. |
105241 | 219 PREBUTTONTEXT is some text between prefix and the buffer button." |
220 (let ((start (point)) | |
221 (end nil) | |
222 (str (format "%S" buffer)) | |
223 (tip nil)) | |
224 (insert prefix prebuttontext str) | |
225 (setq end (point)) | |
226 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
227 (put-text-property start end 'ddebug buffer) | |
228 (put-text-property start end 'ddebug-indent(length prefix)) | |
229 (put-text-property start end 'ddebug-prefix prefix) | |
230 (put-text-property start end 'help-echo tip) | |
231 (put-text-property start end 'ddebug-function | |
232 'data-debug-insert-buffer-from-point) | |
233 (insert "\n") | |
234 ) | |
235 ) | |
236 | |
237 ;;; buffer list | |
238 ;; | |
239 (defun data-debug-insert-buffer-list (bufferlist prefix) | |
240 "Insert all the parts of BUFFERLIST. | |
241 PREFIX specifies what to insert at the start of each line." | |
242 (while bufferlist | |
243 (data-debug-insert-buffer-button (car bufferlist) | |
244 prefix | |
245 "") | |
246 (setq bufferlist (cdr bufferlist)))) | |
247 | |
248 (defun data-debug-insert-buffer-list-from-point (point) | |
249 "Insert the buffer found at the buffer list button at POINT." | |
250 (let ((bufferlist (get-text-property point 'ddebug)) | |
251 (indent (get-text-property point 'ddebug-indent)) | |
252 start | |
253 ) | |
254 (end-of-line) | |
255 (setq start (point)) | |
256 (forward-char 1) | |
257 (data-debug-insert-buffer-list bufferlist | |
258 (concat (make-string indent ? ) | |
259 "* ")) | |
260 (goto-char start) | |
261 )) | |
262 | |
263 (defun data-debug-insert-buffer-list-button (bufferlist | |
264 prefix | |
265 prebuttontext) | |
266 "Insert a button representing BUFFERLIST. | |
105325 | 267 PREFIX is the text that precedes the button. |
105241 | 268 PREBUTTONTEXT is some text between prefix and the buffer list button." |
269 (let ((start (point)) | |
270 (end nil) | |
271 (str (format "#<buffer list: %d entries>" (length bufferlist))) | |
272 (tip nil)) | |
273 (insert prefix prebuttontext str) | |
274 (setq end (point)) | |
275 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
276 (put-text-property start end 'ddebug bufferlist) | |
277 (put-text-property start end 'ddebug-indent(length prefix)) | |
278 (put-text-property start end 'ddebug-prefix prefix) | |
279 (put-text-property start end 'help-echo tip) | |
280 (put-text-property start end 'ddebug-function | |
281 'data-debug-insert-buffer-list-from-point) | |
282 (insert "\n") | |
283 ) | |
284 ) | |
285 | |
286 ;;; processes | |
287 ;; | |
288 (defun data-debug-insert-process-props (process prefix) | |
289 "Insert all the parts of PROCESS. | |
290 PREFIX specifies what to insert at the start of each line." | |
291 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) | |
292 (id (process-id process)) | |
293 (tty (process-tty-name process)) | |
294 (pcontact (process-contact process t)) | |
295 (proplist (process-plist process))) | |
296 (data-debug-insert-property-list | |
297 (append | |
298 (if id (list 'id id)) | |
299 (if tty (list 'tty tty)) | |
300 (if pcontact pcontact) | |
301 proplist) | |
302 attrprefix) | |
303 ) | |
304 ) | |
305 | |
306 (defun data-debug-insert-process-from-point (point) | |
307 "Insert the process found at the process button at POINT." | |
308 (let ((process (get-text-property point 'ddebug)) | |
309 (indent (get-text-property point 'ddebug-indent)) | |
310 start | |
311 ) | |
312 (end-of-line) | |
313 (setq start (point)) | |
314 (forward-char 1) | |
315 (data-debug-insert-process-props process | |
316 (concat (make-string indent ? ) | |
317 "| ")) | |
318 (goto-char start) | |
319 )) | |
320 | |
321 (defun data-debug-insert-process-button (process prefix prebuttontext) | |
322 "Insert a button representing PROCESS. | |
105325 | 323 PREFIX is the text that precedes the button. |
105241 | 324 PREBUTTONTEXT is some text between prefix and the process button." |
325 (let ((start (point)) | |
326 (end nil) | |
327 (str (format "%S : %s" process (process-status process))) | |
328 (tip nil)) | |
329 (insert prefix prebuttontext str) | |
330 (setq end (point)) | |
331 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
332 (put-text-property start end 'ddebug process) | |
333 (put-text-property start end 'ddebug-indent(length prefix)) | |
334 (put-text-property start end 'ddebug-prefix prefix) | |
335 (put-text-property start end 'help-echo tip) | |
336 (put-text-property start end 'ddebug-function | |
337 'data-debug-insert-process-from-point) | |
338 (insert "\n") | |
339 ) | |
340 ) | |
341 | |
342 ;;; Rings | |
343 ;; | |
344 ;; A ring (like kill-ring, or whatever.) | |
345 (defun data-debug-insert-ring-contents (ring prefix) | |
346 "Insert all the parts of RING. | |
347 PREFIX specifies what to insert at the start of each line." | |
348 (let ((len (ring-length ring)) | |
349 (idx 0) | |
350 ) | |
351 (while (< idx len) | |
352 (data-debug-insert-thing (ring-ref ring idx) prefix "") | |
353 (setq idx (1+ idx)) | |
354 ))) | |
355 | |
356 (defun data-debug-insert-ring-items-from-point (point) | |
357 "Insert the ring found at the ring button at POINT." | |
358 (let ((ring (get-text-property point 'ddebug)) | |
359 (indent (get-text-property point 'ddebug-indent)) | |
360 start | |
361 ) | |
362 (end-of-line) | |
363 (setq start (point)) | |
364 (forward-char 1) | |
365 (data-debug-insert-ring-contents ring | |
366 (concat (make-string indent ? ) | |
367 "} ")) | |
368 (goto-char start) | |
369 )) | |
370 | |
371 (defun data-debug-insert-ring-button (ring | |
372 prefix | |
373 prebuttontext) | |
374 "Insert a button representing RING. | |
105325 | 375 PREFIX is the text that precedes the button. |
105241 | 376 PREBUTTONTEXT is some text between prefix and the stuff list button." |
377 (let* ((start (point)) | |
378 (end nil) | |
379 (str (format "#<RING: %d, %d max>" | |
380 (ring-length ring) | |
381 (ring-size ring))) | |
382 (ringthing | |
383 (if (= (ring-length ring) 0) nil (ring-ref ring 0))) | |
384 (tip (format "Ring max-size %d, length %d." | |
385 (ring-size ring) | |
386 (ring-length ring))) | |
387 ) | |
388 (insert prefix prebuttontext str) | |
389 (setq end (point)) | |
390 (put-text-property (- end (length str)) end 'face 'font-lock-type-face) | |
391 (put-text-property start end 'ddebug ring) | |
392 (put-text-property start end 'ddebug-indent(length prefix)) | |
393 (put-text-property start end 'ddebug-prefix prefix) | |
394 (put-text-property start end 'help-echo tip) | |
395 (put-text-property start end 'ddebug-function | |
396 'data-debug-insert-ring-items-from-point) | |
397 (insert "\n") | |
398 ) | |
399 ) | |
400 | |
401 | |
402 ;;; Hash-table | |
403 ;; | |
404 | |
405 (defun data-debug-insert-hash-table (hash-table prefix) | |
406 "Insert the contents of HASH-TABLE inserting PREFIX before each element." | |
407 (maphash | |
408 (lambda (key value) | |
409 (data-debug-insert-thing | |
410 key prefix | |
411 (dd-propertize "key " 'face font-lock-comment-face)) | |
412 (data-debug-insert-thing | |
413 value prefix | |
414 (dd-propertize "val " 'face font-lock-comment-face))) | |
415 hash-table)) | |
416 | |
417 (defun data-debug-insert-hash-table-from-point (point) | |
418 "Insert the contents of the hash-table button at POINT." | |
419 (let ((hash-table (get-text-property point 'ddebug)) | |
420 (indent (get-text-property point 'ddebug-indent)) | |
421 start) | |
422 (end-of-line) | |
423 (setq start (point)) | |
424 (forward-char 1) | |
425 (data-debug-insert-hash-table | |
426 hash-table | |
427 (concat (make-string indent ? ) "> ")) | |
428 (goto-char start)) | |
429 ) | |
430 | |
431 (defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext) | |
432 "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text." | |
433 (let ((string (dd-propertize (format "%s" hash-table) | |
434 'face 'font-lock-keyword-face))) | |
435 (insert (dd-propertize | |
436 (concat prefix prebuttontext string) | |
437 'ddebug hash-table | |
438 'ddebug-indent (length prefix) | |
439 'ddebug-prefix prefix | |
440 'help-echo | |
441 (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)" | |
442 (hash-table-test hash-table) | |
443 (if (hash-table-weakness hash-table) "yes" "no") | |
444 (hash-table-count hash-table) | |
445 (hash-table-size hash-table)) | |
446 'ddebug-function | |
447 'data-debug-insert-hash-table-from-point) | |
448 "\n")) | |
449 ) | |
450 | |
451 ;;; Widget | |
452 ;; | |
453 ;; Widgets have a long list of properties | |
454 (defun data-debug-insert-widget-properties (widget prefix) | |
455 "Insert the contents of WIDGET inserting PREFIX before each element." | |
456 (let ((type (car widget)) | |
457 (rest (cdr widget))) | |
458 (while rest | |
459 (data-debug-insert-thing (car (cdr rest)) | |
460 prefix | |
461 (concat | |
462 (dd-propertize (format "%s" (car rest)) | |
463 'face font-lock-comment-face) | |
464 " : ")) | |
465 (setq rest (cdr (cdr rest)))) | |
466 )) | |
467 | |
468 (defun data-debug-insert-widget-from-point (point) | |
469 "Insert the contents of the widget button at POINT." | |
470 (let ((widget (get-text-property point 'ddebug)) | |
471 (indent (get-text-property point 'ddebug-indent)) | |
472 start) | |
473 (end-of-line) | |
474 (setq start (point)) | |
475 (forward-char 1) | |
476 (data-debug-insert-widget-properties | |
477 widget (concat (make-string indent ? ) "# ")) | |
478 (goto-char start)) | |
479 ) | |
480 | |
481 (defun data-debug-insert-widget (widget prefix prebuttontext) | |
482 "Insert one WIDGET. | |
483 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 484 PREFIX is the text that precedes the button. |
105241 | 485 PREBUTTONTEXT is some text between prefix and the thing." |
486 (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget)) | |
487 'face 'font-lock-keyword-face))) | |
488 (insert (dd-propertize | |
489 (concat prefix prebuttontext string) | |
490 'ddebug widget | |
491 'ddebug-indent (length prefix) | |
492 'ddebug-prefix prefix | |
493 'help-echo | |
494 (format "Widget\nType: %s\n# Properties: %d" | |
495 (car widget) | |
496 (/ (1- (length widget)) 2)) | |
497 'ddebug-function | |
498 'data-debug-insert-widget-from-point) | |
499 "\n"))) | |
500 | |
501 ;;; list of stuff | |
502 ;; | |
503 ;; just a list. random stuff inside. | |
504 (defun data-debug-insert-stuff-list (stufflist prefix) | |
505 "Insert all the parts of STUFFLIST. | |
506 PREFIX specifies what to insert at the start of each line." | |
507 (while stufflist | |
508 (data-debug-insert-thing | |
509 ;; Some lists may put a value in the CDR | |
510 (if (listp stufflist) (car stufflist) stufflist) | |
511 prefix | |
512 "") | |
513 (setq stufflist | |
514 (if (listp stufflist) | |
515 (cdr-safe stufflist) | |
516 nil)))) | |
517 | |
518 (defun data-debug-insert-stuff-list-from-point (point) | |
519 "Insert the stuff found at the stuff list button at POINT." | |
520 (let ((stufflist (get-text-property point 'ddebug)) | |
521 (indent (get-text-property point 'ddebug-indent)) | |
522 start | |
523 ) | |
524 (end-of-line) | |
525 (setq start (point)) | |
526 (forward-char 1) | |
527 (data-debug-insert-stuff-list stufflist | |
528 (concat (make-string indent ? ) | |
529 "> ")) | |
530 (goto-char start) | |
531 )) | |
532 | |
533 (defun data-debug-insert-stuff-list-button (stufflist | |
534 prefix | |
535 prebuttontext) | |
536 "Insert a button representing STUFFLIST. | |
105325 | 537 PREFIX is the text that precedes the button. |
105241 | 538 PREBUTTONTEXT is some text between prefix and the stuff list button." |
539 (let ((start (point)) | |
540 (end nil) | |
541 (str | |
542 (condition-case nil | |
543 (format "#<list o' stuff: %d entries>" (safe-length stufflist)) | |
544 (error "#<list o' stuff>"))) | |
545 (tip (if (or (listp (car stufflist)) | |
546 (vectorp (car stufflist))) | |
547 "" | |
548 (format "%s" stufflist)))) | |
549 (insert prefix prebuttontext str) | |
550 (setq end (point)) | |
551 (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) | |
552 (put-text-property start end 'ddebug stufflist) | |
553 (put-text-property start end 'ddebug-indent (length prefix)) | |
554 (put-text-property start end 'ddebug-prefix prefix) | |
555 (put-text-property start end 'help-echo tip) | |
556 (put-text-property start end 'ddebug-function | |
557 'data-debug-insert-stuff-list-from-point) | |
558 (insert "\n") | |
559 ) | |
560 ) | |
561 | |
562 ;;; vector of stuff | |
563 ;; | |
564 ;; just a vector. random stuff inside. | |
565 (defun data-debug-insert-stuff-vector (stuffvector prefix) | |
566 "Insert all the parts of STUFFVECTOR. | |
567 PREFIX specifies what to insert at the start of each line." | |
568 (let ((idx 0)) | |
569 (while (< idx (length stuffvector)) | |
570 (data-debug-insert-thing | |
571 ;; Some vectors may put a value in the CDR | |
572 (aref stuffvector idx) | |
573 prefix | |
574 "") | |
575 (setq idx (1+ idx))))) | |
576 | |
577 (defun data-debug-insert-stuff-vector-from-point (point) | |
578 "Insert the stuff found at the stuff vector button at POINT." | |
579 (let ((stuffvector (get-text-property point 'ddebug)) | |
580 (indent (get-text-property point 'ddebug-indent)) | |
581 start | |
582 ) | |
583 (end-of-line) | |
584 (setq start (point)) | |
585 (forward-char 1) | |
586 (data-debug-insert-stuff-vector stuffvector | |
587 (concat (make-string indent ? ) | |
588 "[ ")) | |
589 (goto-char start) | |
590 )) | |
591 | |
592 (defun data-debug-insert-stuff-vector-button (stuffvector | |
593 prefix | |
594 prebuttontext) | |
595 "Insert a button representing STUFFVECTOR. | |
105325 | 596 PREFIX is the text that precedes the button. |
105241 | 597 PREBUTTONTEXT is some text between prefix and the stuff vector button." |
598 (let* ((start (point)) | |
599 (end nil) | |
600 (str (format "#<vector o' stuff: %d entries>" (length stuffvector))) | |
601 (tip str)) | |
602 (insert prefix prebuttontext str) | |
603 (setq end (point)) | |
604 (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) | |
605 (put-text-property start end 'ddebug stuffvector) | |
606 (put-text-property start end 'ddebug-indent (length prefix)) | |
607 (put-text-property start end 'ddebug-prefix prefix) | |
608 (put-text-property start end 'help-echo tip) | |
609 (put-text-property start end 'ddebug-function | |
610 'data-debug-insert-stuff-vector-from-point) | |
611 (insert "\n") | |
612 ) | |
613 ) | |
614 | |
615 ;;; Symbol | |
616 ;; | |
617 | |
618 (defun data-debug-insert-symbol-from-point (point) | |
619 "Insert attached properties and possibly the value of symbol at POINT." | |
620 (let ((symbol (get-text-property point 'ddebug)) | |
621 (indent (get-text-property point 'ddebug-indent)) | |
622 start) | |
623 (end-of-line) | |
624 (setq start (point)) | |
625 (forward-char 1) | |
626 (when (and (not (fboundp symbol)) (boundp symbol)) | |
627 (data-debug-insert-thing | |
628 (symbol-value symbol) | |
629 (concat (make-string indent ? ) "> ") | |
630 (concat | |
631 (dd-propertize "value" | |
632 'face 'font-lock-comment-face) | |
633 " "))) | |
634 (data-debug-insert-property-list | |
635 (symbol-plist symbol) | |
636 (concat (make-string indent ? ) "> ")) | |
637 (goto-char start)) | |
638 ) | |
639 | |
640 (defun data-debug-insert-symbol-button (symbol prefix prebuttontext) | |
641 "Insert a button representing SYMBOL. | |
105325 | 642 PREFIX is the text that precedes the button. |
643 PREBUTTONTEXT is some text between prefix and the symbol button." | |
105241 | 644 (let ((string |
645 (cond ((fboundp symbol) | |
646 (dd-propertize (concat "#'" (symbol-name symbol)) | |
647 'face 'font-lock-function-name-face)) | |
648 ((boundp symbol) | |
649 (dd-propertize (concat "'" (symbol-name symbol)) | |
650 'face 'font-lock-variable-name-face)) | |
651 (t (format "'%s" symbol))))) | |
652 (insert (dd-propertize | |
653 (concat prefix prebuttontext string) | |
654 'ddebug symbol | |
655 'ddebug-indent (length prefix) | |
656 'ddebug-prefix prefix | |
657 'help-echo "" | |
658 'ddebug-function | |
659 'data-debug-insert-symbol-from-point) | |
660 "\n")) | |
661 ) | |
662 | |
663 ;;; String | |
664 (defun data-debug-insert-string (thing prefix prebuttontext) | |
665 "Insert one symbol THING. | |
666 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 667 PREFIX is the text that precedes the button. |
105241 | 668 PREBUTTONTEXT is some text between prefix and the thing." |
669 (let ((newstr thing)) | |
670 (while (string-match "\n" newstr) | |
671 (setq newstr (replace-match "\\n" t t newstr))) | |
672 (while (string-match "\t" newstr) | |
673 (setq newstr (replace-match "\\t" t t newstr))) | |
674 (insert prefix prebuttontext | |
675 (dd-propertize (format "\"%s\"" newstr) | |
676 'face font-lock-string-face) | |
677 "\n" ))) | |
678 | |
679 ;;; Number | |
680 (defun data-debug-insert-number (thing prefix prebuttontext) | |
681 "Insert one symbol THING. | |
682 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 683 PREFIX is the text that precedes the button. |
105241 | 684 PREBUTTONTEXT is some text between prefix and the thing." |
685 (insert prefix prebuttontext | |
686 (dd-propertize (format "%S" thing) | |
687 'face font-lock-string-face) | |
688 "\n")) | |
689 | |
690 ;;; Lambda Expression | |
691 (defun data-debug-insert-lambda-expression (thing prefix prebuttontext) | |
692 "Insert one lambda expression THING. | |
693 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 694 PREFIX is the text that precedes the button. |
105241 | 695 PREBUTTONTEXT is some text between prefix and the thing." |
696 (let ((txt (prin1-to-string thing))) | |
697 (data-debug-insert-simple-thing | |
698 txt prefix prebuttontext 'font-lock-keyword-face)) | |
699 ) | |
700 | |
701 ;;; nil thing | |
702 (defun data-debug-insert-nil (thing prefix prebuttontext) | |
703 "Insert one simple THING with a face. | |
105325 | 704 PREFIX is the text that precedes the button. |
105241 | 705 PREBUTTONTEXT is some text between prefix and the thing. |
706 FACE is the face to use." | |
707 (insert prefix prebuttontext) | |
708 (insert ": ") | |
709 (let ((start (point)) | |
710 (end nil)) | |
711 (insert "nil") | |
712 (setq end (point)) | |
713 (insert "\n" ) | |
714 (put-text-property start end 'face 'font-lock-variable-name-face) | |
715 )) | |
716 | |
717 ;;; simple thing | |
718 (defun data-debug-insert-simple-thing (thing prefix prebuttontext face) | |
719 "Insert one simple THING with a face. | |
105325 | 720 PREFIX is the text that precedes the button. |
105241 | 721 PREBUTTONTEXT is some text between prefix and the thing. |
722 FACE is the face to use." | |
723 (insert prefix prebuttontext) | |
724 (let ((start (point)) | |
725 (end nil)) | |
726 (insert (format "%s" thing)) | |
727 (setq end (point)) | |
728 (insert "\n" ) | |
729 (put-text-property start end 'face face) | |
730 )) | |
731 | |
732 ;;; custom thing | |
733 (defun data-debug-insert-custom (thingstring prefix prebuttontext face) | |
734 "Insert one simple THINGSTRING with a face. | |
735 Use for simple items that need a custom insert. | |
105325 | 736 PREFIX is the text that precedes the button. |
105241 | 737 PREBUTTONTEXT is some text between prefix and the thing. |
738 FACE is the face to use." | |
739 (insert prefix prebuttontext) | |
740 (let ((start (point)) | |
741 (end nil)) | |
742 (insert thingstring) | |
743 (setq end (point)) | |
744 (insert "\n" ) | |
745 (put-text-property start end 'face face) | |
746 )) | |
747 | |
748 | |
749 (defvar data-debug-thing-alist | |
750 '( | |
751 ;; nil | |
752 (null . data-debug-insert-nil) | |
753 | |
754 ;; Overlay | |
755 (data-debug-overlay-p . data-debug-insert-overlay-button) | |
756 | |
757 ;; Overlay list | |
758 ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) . | |
759 data-debug-insert-overlay-list-button) | |
760 | |
761 ;; Buffer | |
762 (bufferp . data-debug-insert-buffer-button) | |
763 | |
764 ;; Buffer list | |
765 ((lambda (thing) (and (consp thing) (bufferp (car thing)))) . | |
766 data-debug-insert-buffer-list-button) | |
767 | |
768 ;; Process | |
769 (processp . data-debug-insert-process-button) | |
770 | |
771 ;; String | |
772 (stringp . data-debug-insert-string) | |
773 | |
774 ;; Number | |
775 (numberp . data-debug-insert-number) | |
776 | |
777 ;; Symbol | |
778 (symbolp . data-debug-insert-symbol-button) | |
779 | |
780 ;; Ring | |
781 (ring-p . data-debug-insert-ring-button) | |
782 | |
783 ;; Lambda Expression | |
784 ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) . | |
785 data-debug-insert-lambda-expression) | |
786 | |
787 ;; Hash-table | |
788 (hash-table-p . data-debug-insert-hash-table-button) | |
789 | |
790 ;; Widgets | |
791 (widgetp . data-debug-insert-widget) | |
792 | |
793 ;; List of stuff | |
794 (listp . data-debug-insert-stuff-list-button) | |
795 | |
796 ;; Vector of stuff | |
797 (vectorp . data-debug-insert-stuff-vector-button) | |
798 ) | |
799 "Alist of methods used to insert things into an Ddebug buffer.") | |
800 | |
801 ;; An augmentation function for the thing alist. | |
802 (defun data-debug-add-specialized-thing (predicate fcn) | |
803 "Add a new specialized thing to display with data-debug. | |
804 PREDICATE is a function that returns t if a thing is this new type. | |
805 FCN is a function that will display stuff in the data debug buffer." | |
806 (let ((entry (cons predicate fcn)) | |
807 ;; Specialized entries show up AFTER nil, | |
808 ;; but before listp, vectorp, symbolp, and | |
809 ;; other general things. Splice it into | |
810 ;; the beginning. | |
811 (first (nthcdr 0 data-debug-thing-alist)) | |
812 (second (nthcdr 1 data-debug-thing-alist)) | |
813 ) | |
814 (when (not (member entry data-debug-thing-alist)) | |
815 (setcdr first (cons entry second))))) | |
816 | |
817 ;; uber insert method | |
818 (defun data-debug-insert-thing (thing prefix prebuttontext &optional parent) | |
819 "Insert THING with PREFIX. | |
820 PREBUTTONTEXT is some text to insert between prefix and the thing | |
821 that is not included in the indentation calculation of any children. | |
822 If PARENT is non-nil, it is somehow related as a parent to thing." | |
823 (when (catch 'done | |
824 (dolist (test data-debug-thing-alist) | |
825 (when (funcall (car test) thing) | |
826 (condition-case nil | |
827 (funcall (cdr test) thing prefix prebuttontext parent) | |
828 (error | |
829 (funcall (cdr test) thing prefix prebuttontext))) | |
830 (throw 'done nil)) | |
831 ) | |
832 nil) | |
833 (data-debug-insert-simple-thing (format "%S" thing) | |
834 prefix | |
835 prebuttontext | |
836 'bold))) | |
837 | |
838 ;;; MAJOR MODE | |
839 ;; | |
840 ;; The Ddebug major mode provides an interactive space to explore | |
841 ;; complicated data structures. | |
842 ;; | |
843 (defgroup data-debug nil | |
844 "data-debug group." | |
107167
f6b8c73548b3
Minor tweaks to custom groups.
Chong Yidong <cyd@stupidchicken.com>
parents:
106815
diff
changeset
|
845 :group 'extensions) |
105241 | 846 |
847 (defvar data-debug-mode-syntax-table | |
848 (let ((table (make-syntax-table (standard-syntax-table)))) | |
849 (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; | |
850 (modify-syntax-entry ?\n ">" table) ;; Comment end | |
851 (modify-syntax-entry ?\" "\"" table) ;; String | |
852 (modify-syntax-entry ?\- "_" table) ;; Symbol | |
853 (modify-syntax-entry ?\\ "\\" table) ;; Quote | |
854 (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) | |
855 (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) | |
856 (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) | |
857 | |
858 table) | |
859 "Syntax table used in data-debug macro buffers.") | |
860 | |
861 (defvar data-debug-map | |
862 (let ((km (make-sparse-keymap))) | |
863 (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse) | |
864 (define-key km " " 'data-debug-expand-or-contract) | |
865 (define-key km "\C-m" 'data-debug-expand-or-contract) | |
866 (define-key km "n" 'data-debug-next) | |
867 (define-key km "p" 'data-debug-prev) | |
868 (define-key km "N" 'data-debug-next-expando) | |
869 (define-key km "P" 'data-debug-prev-expando) | |
870 km) | |
871 "Keymap used in data-debug.") | |
872 | |
873 (defcustom data-debug-mode-hook nil | |
874 "*Hook run when data-debug starts." | |
875 :group 'data-debug | |
876 :type 'hook) | |
877 | |
878 (defun data-debug-mode () | |
879 "Major-mode for the Analyzer debugger. | |
880 | |
881 \\{data-debug-map}" | |
882 (interactive) | |
883 (kill-all-local-variables) | |
884 (setq major-mode 'data-debug-mode | |
885 mode-name "DATA-DEBUG" | |
886 comment-start ";;" | |
887 comment-end "") | |
888 (set (make-local-variable 'comment-start-skip) | |
889 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") | |
890 (set-syntax-table data-debug-mode-syntax-table) | |
891 (use-local-map data-debug-map) | |
892 (run-hooks 'data-debug-hook) | |
893 (buffer-disable-undo) | |
894 (set (make-local-variable 'font-lock-global-modes) nil) | |
895 (font-lock-mode -1) | |
896 ) | |
897 | |
898 ;;;###autoload | |
899 (defun data-debug-new-buffer (name) | |
900 "Create a new data-debug buffer with NAME." | |
901 (let ((b (get-buffer-create name))) | |
902 (pop-to-buffer b) | |
903 (set-buffer b) | |
904 (erase-buffer) | |
905 (data-debug-mode) | |
906 b)) | |
907 | |
908 ;;; Ddebug mode commands | |
909 ;; | |
910 (defun data-debug-next () | |
911 "Go to the next line in the Ddebug buffer." | |
912 (interactive) | |
913 (forward-line 1) | |
914 (beginning-of-line) | |
915 (skip-chars-forward " *-><[]" (point-at-eol))) | |
916 | |
917 (defun data-debug-prev () | |
918 "Go to the next line in the Ddebug buffer." | |
919 (interactive) | |
920 (forward-line -1) | |
921 (beginning-of-line) | |
922 (skip-chars-forward " *-><[]" (point-at-eol))) | |
923 | |
924 (defun data-debug-next-expando () | |
925 "Go to the next line in the Ddebug buffer. | |
926 Contract the current line (if open) and expand the line | |
927 we move to." | |
928 (interactive) | |
929 (data-debug-contract-current-line) | |
930 (data-debug-next) | |
931 (data-debug-expand-current-line) | |
932 ) | |
933 | |
934 (defun data-debug-prev-expando () | |
935 "Go to the previous line in the Ddebug buffer. | |
936 Contract the current line (if open) and expand the line | |
937 we move to." | |
938 (interactive) | |
939 (data-debug-contract-current-line) | |
940 (data-debug-prev) | |
941 (data-debug-expand-current-line) | |
942 ) | |
943 | |
944 (defun data-debug-current-line-expanded-p () | |
945 "Return non-nil if the current line is expanded." | |
946 (let ((ti (current-indentation)) | |
947 (ni (condition-case nil | |
948 (save-excursion | |
949 (end-of-line) | |
950 (forward-char 1) | |
951 (current-indentation)) | |
952 (error 0)))) | |
953 (> ni ti))) | |
954 | |
955 (defun data-debug-line-expandable-p () | |
956 "Return non-nil if the current line is expandable. | |
957 Lines that are not expandable are assumed to not be contractable." | |
958 (not (get-text-property (point) 'ddebug-noexpand))) | |
959 | |
960 (defun data-debug-expand-current-line () | |
961 "Expand the current line (if possible). | |
962 Do nothing if already expanded." | |
963 (when (or (not (data-debug-line-expandable-p)) | |
964 (not (data-debug-current-line-expanded-p))) | |
965 ;; If the next line is the same or less indentation, expand. | |
966 (let ((fcn (get-text-property (point) 'ddebug-function))) | |
967 (when fcn | |
968 (funcall fcn (point)) | |
969 (beginning-of-line) | |
970 )))) | |
971 | |
972 (defun data-debug-contract-current-line () | |
973 "Contract the current line (if possible). | |
974 Do nothing if already expanded." | |
975 (when (and (data-debug-current-line-expanded-p) | |
976 ;; Don't contract if the current line is not expandable. | |
977 (get-text-property (point) 'ddebug-function)) | |
978 (let ((ti (current-indentation)) | |
979 ) | |
980 ;; If next indentation is larger, collapse. | |
981 (end-of-line) | |
982 (forward-char 1) | |
983 (let ((start (point)) | |
984 (end nil)) | |
985 (condition-case nil | |
986 (progn | |
987 ;; Keep checking indentation | |
988 (while (or (> (current-indentation) ti) | |
989 (looking-at "^\\s-*$")) | |
990 (end-of-line) | |
991 (forward-char 1)) | |
992 (setq end (point)) | |
993 ) | |
994 (error (setq end (point-max)))) | |
995 (delete-region start end) | |
996 (forward-char -1) | |
997 (beginning-of-line))))) | |
998 | |
999 (defun data-debug-expand-or-contract () | |
1000 "Expand or contract anything at the current point." | |
1001 (interactive) | |
1002 (if (and (data-debug-line-expandable-p) | |
1003 (data-debug-current-line-expanded-p)) | |
1004 (data-debug-contract-current-line) | |
1005 (data-debug-expand-current-line)) | |
1006 (skip-chars-forward " *-><[]" (point-at-eol))) | |
1007 | |
1008 (defun data-debug-expand-or-contract-mouse (event) | |
1009 "Expand or contract anything at event EVENT." | |
1010 (interactive "e") | |
1011 (let* ((win (car (car (cdr event)))) | |
1012 ) | |
1013 (select-window win t) | |
1014 (save-excursion | |
1015 ;(goto-char (window-start win)) | |
1016 (mouse-set-point event) | |
1017 (data-debug-expand-or-contract)) | |
1018 )) | |
1019 | |
1020 ;;; GENERIC STRUCTURE DUMP | |
1021 ;; | |
1022 (defun data-debug-show-stuff (stuff name) | |
1023 "Data debug STUFF in a buffer named *NAME DDebug*." | |
1024 (data-debug-new-buffer (concat "*" name " DDebug*")) | |
1025 (data-debug-insert-thing stuff "?" "") | |
1026 (goto-char (point-min)) | |
1027 (when (data-debug-line-expandable-p) | |
1028 (data-debug-expand-current-line))) | |
1029 | |
1030 ;;; DEBUG COMMANDS | |
1031 ;; | |
1032 ;; Various commands for displaying complex data structures. | |
1033 | |
1034 (defun data-debug-edebug-expr (expr) | |
105325 | 1035 "Dump out the contents of some expression EXPR in edebug with ddebug." |
105241 | 1036 (interactive |
1037 (list (let ((minibuffer-completing-symbol t)) | |
1038 (read-from-minibuffer "Eval: " | |
1039 nil read-expression-map t | |
1040 'read-expression-history)) | |
1041 )) | |
1042 (let ((v (eval expr))) | |
1043 (if (not v) | |
1044 (message "Expression %s is nil." expr) | |
1045 (data-debug-show-stuff v "expression")))) | |
1046 | |
1047 (defun data-debug-eval-expression (expr) | |
1048 "Evaluate EXPR and display the value. | |
1049 If the result is something simple, show it in the echo area. | |
1050 If the result is a list or vector, then use the data debugger to display it." | |
1051 (interactive | |
1052 (list (let ((minibuffer-completing-symbol t)) | |
1053 (read-from-minibuffer "Eval: " | |
1054 nil read-expression-map t | |
1055 'read-expression-history)) | |
1056 )) | |
1057 | |
1058 (if (null eval-expression-debug-on-error) | |
1059 (setq values (cons (eval expr) values)) | |
1060 (let ((old-value (make-symbol "t")) new-value) | |
1061 ;; Bind debug-on-error to something unique so that we can | |
1062 ;; detect when evaled code changes it. | |
1063 (let ((debug-on-error old-value)) | |
1064 (setq values (cons (eval expr) values)) | |
1065 (setq new-value debug-on-error)) | |
1066 ;; If evaled code has changed the value of debug-on-error, | |
1067 ;; propagate that change to the global binding. | |
1068 (unless (eq old-value new-value) | |
1069 (setq debug-on-error new-value)))) | |
1070 | |
1071 (if (or (consp (car values)) (vectorp (car values))) | |
1072 (let ((v (car values))) | |
1073 (data-debug-show-stuff v "Expression")) | |
1074 ;; Old style | |
1075 (prog1 | |
1076 (prin1 (car values) t) | |
1077 (let ((str (eval-expression-print-format (car values)))) | |
1078 (if str (princ str t)))))) | |
1079 | |
1080 (provide 'data-debug) | |
1081 | |
1082 (if (featurep 'eieio) | |
1083 (require 'eieio-datadebug)) | |
1084 | |
105377 | 1085 ;; arch-tag: 4807227d-08e7-45c4-8ea5-9e4595c3bfb1 |
105241 | 1086 ;;; data-debug.el ends here |