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 | |
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. | |
bd2afec2 | 114 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 163 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 218 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 267 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 323 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 375 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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 | \f | |
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. | |
bd2afec2 | 484 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 537 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 596 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 GM |
642 | PREFIX is the text that precedes the button. |
643 | PREBUTTONTEXT is some text between prefix and the symbol button." | |
666fd2cc CY |
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. | |
bd2afec2 | 667 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 683 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 694 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 704 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 720 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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. | |
bd2afec2 | 736 | PREFIX is the text that precedes the button. |
666fd2cc CY |
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." | |
ff90f4b0 | 845 | :group 'extensions) |
666fd2cc CY |
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) | |
bd2afec2 | 1035 | "Dump out the contents of some expression EXPR in edebug with ddebug." |
666fd2cc CY |
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 | ||
3999968a | 1085 | ;; arch-tag: 4807227d-08e7-45c4-8ea5-9e4595c3bfb1 |
666fd2cc | 1086 | ;;; data-debug.el ends here |