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