diff options
author | Chong Yidong <cyd@stupidchicken.com> | 2009-09-28 01:28:41 +0000 |
---|---|---|
committer | Chong Yidong <cyd@stupidchicken.com> | 2009-09-28 01:28:41 +0000 |
commit | 666fd2cc6572fddd8a9a021b0359c651ac73a32d (patch) | |
tree | 147f72fea73e3d6325462ea1e6b1b1aded149be9 /lisp/cedet/data-debug.el | |
parent | 748e162f10771f0482eaa29444a0d3e3ba738e98 (diff) | |
download | emacs-666fd2cc6572fddd8a9a021b0359c651ac73a32d.tar.gz |
* cedet/cedet-cscope.el:
* cedet/cedet-files.el:
* cedet/cedet-global.el:
* cedet/cedet-idutils.el:
* cedet/data-debug.el:
* cedet/inversion.el:
* cedet/pulse.el: New files.
Diffstat (limited to 'lisp/cedet/data-debug.el')
-rw-r--r-- | lisp/cedet/data-debug.el | 1085 |
1 files changed, 1085 insertions, 0 deletions
diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el new file mode 100644 index 00000000000..d132e47fc9a --- /dev/null +++ b/lisp/cedet/data-debug.el @@ -0,0 +1,1085 @@ +;;; data-debug.el --- Datastructure Debugger + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Provide a simple way to investigate particularly large and complex +;; data structures. +;; +;; The best way to get started is to bind M-: to 'data-debug-eval-expression. +;; +;; (global-set-key "\M-:" 'data-debug-eval-expression) +;; +;; If you write functions with complex output that need debugging, you +;; can make them interactive with data-debug-show-stuff. For example: +;; +;; (defun my-complex-output-fcn () +;; "Calculate something complicated at point, and return it." +;; (interactive) ;; function not normally interactive +;; (let ((stuff (do-stuff))) +;; (when (interactive-p) +;; (data-debug-show-stuff stuff "myStuff")) +;; stuff)) + +(require 'font-lock) +(require 'ring) + +;;; Code: + +;;; Compatibility +;; +(if (featurep 'xemacs) + (eval-and-compile + (defalias 'data-debug-overlay-properties 'extent-properties) + (defalias 'data-debug-overlay-p 'extentp) + (if (not (fboundp 'propertize)) + (defun dd-propertize (string &rest properties) + "Mimic 'propertize' in from Emacs 23." + (add-text-properties 0 (length string) properties string) + string + ) + (defalias 'dd-propertize 'propertize)) + ) + ;; Regular Emacs + (eval-and-compile + (defalias 'data-debug-overlay-properties 'overlay-properties) + (defalias 'data-debug-overlay-p 'overlayp) + (defalias 'dd-propertize 'propertize) + ) + ) + +;;; GENERIC STUFF +;; +(defun data-debug-insert-property-list (proplist prefix &optional parent) + "Insert the property list PROPLIST. +Each line starts with PREFIX. +The attributes belong to the tag PARENT." + (while proplist + (let ((pretext (concat (symbol-name (car proplist)) " : "))) + (data-debug-insert-thing (car (cdr proplist)) + prefix + pretext + parent)) + (setq proplist (cdr (cdr proplist))))) + +;;; overlays +;; +(defun data-debug-insert-overlay-props (overlay prefix) + "Insert all the parts of OVERLAY. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) + (proplist (data-debug-overlay-properties overlay))) + (data-debug-insert-property-list + proplist attrprefix) + ) + ) + +(defun data-debug-insert-overlay-from-point (point) + "Insert the overlay found at the overlay button at POINT." + (let ((overlay (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-overlay-props overlay + (concat (make-string indent ? ) + "| ")) + (goto-char start) + )) + +(defun data-debug-insert-overlay-button (overlay prefix prebuttontext) + "Insert a button representing OVERLAY. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the overlay button." + (let ((start (point)) + (end nil) + (str (format "%s" overlay)) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug overlay) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-overlay-from-point) + (insert "\n") + ) + ) + +;;; overlay list +;; +(defun data-debug-insert-overlay-list (overlaylist prefix) + "Insert all the parts of OVERLAYLIST. +PREFIX specifies what to insert at the start of each line." + (while overlaylist + (data-debug-insert-overlay-button (car overlaylist) + prefix + "") + (setq overlaylist (cdr overlaylist)))) + +(defun data-debug-insert-overlay-list-from-point (point) + "Insert the overlay found at the overlay list button at POINT." + (let ((overlaylist (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-overlay-list overlaylist + (concat (make-string indent ? ) + "* ")) + (goto-char start) + )) + +(defun data-debug-insert-overlay-list-button (overlaylist + prefix + prebuttontext) + "Insert a button representing OVERLAYLIST. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the overlay list button." + (let ((start (point)) + (end nil) + (str (format "#<overlay list: %d entries>" (length overlaylist))) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug overlaylist) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-overlay-list-from-point) + (insert "\n") + ) + ) + +;;; buffers +;; +(defun data-debug-insert-buffer-props (buffer prefix) + "Insert all the parts of BUFFER. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) + (proplist + (list :filename (buffer-file-name buffer) + :live (buffer-live-p buffer) + :modified (buffer-modified-p buffer) + :size (buffer-size buffer) + :process (get-buffer-process buffer) + :localvars (buffer-local-variables buffer) + ))) + (data-debug-insert-property-list + proplist attrprefix) + ) + ) + +(defun data-debug-insert-buffer-from-point (point) + "Insert the buffer found at the buffer button at POINT." + (let ((buffer (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-buffer-props buffer + (concat (make-string indent ? ) + "| ")) + (goto-char start) + )) + +(defun data-debug-insert-buffer-button (buffer prefix prebuttontext) + "Insert a button representing BUFFER. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the buffer button." + (let ((start (point)) + (end nil) + (str (format "%S" buffer)) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug buffer) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-buffer-from-point) + (insert "\n") + ) + ) + +;;; buffer list +;; +(defun data-debug-insert-buffer-list (bufferlist prefix) + "Insert all the parts of BUFFERLIST. +PREFIX specifies what to insert at the start of each line." + (while bufferlist + (data-debug-insert-buffer-button (car bufferlist) + prefix + "") + (setq bufferlist (cdr bufferlist)))) + +(defun data-debug-insert-buffer-list-from-point (point) + "Insert the buffer found at the buffer list button at POINT." + (let ((bufferlist (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-buffer-list bufferlist + (concat (make-string indent ? ) + "* ")) + (goto-char start) + )) + +(defun data-debug-insert-buffer-list-button (bufferlist + prefix + prebuttontext) + "Insert a button representing BUFFERLIST. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the buffer list button." + (let ((start (point)) + (end nil) + (str (format "#<buffer list: %d entries>" (length bufferlist))) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug bufferlist) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-buffer-list-from-point) + (insert "\n") + ) + ) + +;;; processes +;; +(defun data-debug-insert-process-props (process prefix) + "Insert all the parts of PROCESS. +PREFIX specifies what to insert at the start of each line." + (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) + (id (process-id process)) + (tty (process-tty-name process)) + (pcontact (process-contact process t)) + (proplist (process-plist process))) + (data-debug-insert-property-list + (append + (if id (list 'id id)) + (if tty (list 'tty tty)) + (if pcontact pcontact) + proplist) + attrprefix) + ) + ) + +(defun data-debug-insert-process-from-point (point) + "Insert the process found at the process button at POINT." + (let ((process (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-process-props process + (concat (make-string indent ? ) + "| ")) + (goto-char start) + )) + +(defun data-debug-insert-process-button (process prefix prebuttontext) + "Insert a button representing PROCESS. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the process button." + (let ((start (point)) + (end nil) + (str (format "%S : %s" process (process-status process))) + (tip nil)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) + (put-text-property start end 'ddebug process) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-process-from-point) + (insert "\n") + ) + ) + +;;; Rings +;; +;; A ring (like kill-ring, or whatever.) +(defun data-debug-insert-ring-contents (ring prefix) + "Insert all the parts of RING. +PREFIX specifies what to insert at the start of each line." + (let ((len (ring-length ring)) + (idx 0) + ) + (while (< idx len) + (data-debug-insert-thing (ring-ref ring idx) prefix "") + (setq idx (1+ idx)) + ))) + +(defun data-debug-insert-ring-items-from-point (point) + "Insert the ring found at the ring button at POINT." + (let ((ring (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-ring-contents ring + (concat (make-string indent ? ) + "} ")) + (goto-char start) + )) + +(defun data-debug-insert-ring-button (ring + prefix + prebuttontext) + "Insert a button representing RING. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the stuff list button." + (let* ((start (point)) + (end nil) + (str (format "#<RING: %d, %d max>" + (ring-length ring) + (ring-size ring))) + (ringthing + (if (= (ring-length ring) 0) nil (ring-ref ring 0))) + (tip (format "Ring max-size %d, length %d." + (ring-size ring) + (ring-length ring))) + ) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-type-face) + (put-text-property start end 'ddebug ring) + (put-text-property start end 'ddebug-indent(length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-ring-items-from-point) + (insert "\n") + ) + ) + + +;;; Hash-table +;; + +(defun data-debug-insert-hash-table (hash-table prefix) + "Insert the contents of HASH-TABLE inserting PREFIX before each element." + (maphash + (lambda (key value) + (data-debug-insert-thing + key prefix + (dd-propertize "key " 'face font-lock-comment-face)) + (data-debug-insert-thing + value prefix + (dd-propertize "val " 'face font-lock-comment-face))) + hash-table)) + +(defun data-debug-insert-hash-table-from-point (point) + "Insert the contents of the hash-table button at POINT." + (let ((hash-table (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-hash-table + hash-table + (concat (make-string indent ? ) "> ")) + (goto-char start)) + ) + +(defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext) + "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text." + (let ((string (dd-propertize (format "%s" hash-table) + 'face 'font-lock-keyword-face))) + (insert (dd-propertize + (concat prefix prebuttontext string) + 'ddebug hash-table + 'ddebug-indent (length prefix) + 'ddebug-prefix prefix + 'help-echo + (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)" + (hash-table-test hash-table) + (if (hash-table-weakness hash-table) "yes" "no") + (hash-table-count hash-table) + (hash-table-size hash-table)) + 'ddebug-function + 'data-debug-insert-hash-table-from-point) + "\n")) + ) + +;;; Widget +;; +;; Widgets have a long list of properties +(defun data-debug-insert-widget-properties (widget prefix) + "Insert the contents of WIDGET inserting PREFIX before each element." + (let ((type (car widget)) + (rest (cdr widget))) + (while rest + (data-debug-insert-thing (car (cdr rest)) + prefix + (concat + (dd-propertize (format "%s" (car rest)) + 'face font-lock-comment-face) + " : ")) + (setq rest (cdr (cdr rest)))) + )) + +(defun data-debug-insert-widget-from-point (point) + "Insert the contents of the widget button at POINT." + (let ((widget (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-widget-properties + widget (concat (make-string indent ? ) "# ")) + (goto-char start)) + ) + +(defun data-debug-insert-widget (widget prefix prebuttontext) + "Insert one WIDGET. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget)) + 'face 'font-lock-keyword-face))) + (insert (dd-propertize + (concat prefix prebuttontext string) + 'ddebug widget + 'ddebug-indent (length prefix) + 'ddebug-prefix prefix + 'help-echo + (format "Widget\nType: %s\n# Properties: %d" + (car widget) + (/ (1- (length widget)) 2)) + 'ddebug-function + 'data-debug-insert-widget-from-point) + "\n"))) + +;;; list of stuff +;; +;; just a list. random stuff inside. +(defun data-debug-insert-stuff-list (stufflist prefix) + "Insert all the parts of STUFFLIST. +PREFIX specifies what to insert at the start of each line." + (while stufflist + (data-debug-insert-thing + ;; Some lists may put a value in the CDR + (if (listp stufflist) (car stufflist) stufflist) + prefix + "") + (setq stufflist + (if (listp stufflist) + (cdr-safe stufflist) + nil)))) + +(defun data-debug-insert-stuff-list-from-point (point) + "Insert the stuff found at the stuff list button at POINT." + (let ((stufflist (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-stuff-list stufflist + (concat (make-string indent ? ) + "> ")) + (goto-char start) + )) + +(defun data-debug-insert-stuff-list-button (stufflist + prefix + prebuttontext) + "Insert a button representing STUFFLIST. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the stuff list button." + (let ((start (point)) + (end nil) + (str + (condition-case nil + (format "#<list o' stuff: %d entries>" (safe-length stufflist)) + (error "#<list o' stuff>"))) + (tip (if (or (listp (car stufflist)) + (vectorp (car stufflist))) + "" + (format "%s" stufflist)))) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) + (put-text-property start end 'ddebug stufflist) + (put-text-property start end 'ddebug-indent (length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-stuff-list-from-point) + (insert "\n") + ) + ) + +;;; vector of stuff +;; +;; just a vector. random stuff inside. +(defun data-debug-insert-stuff-vector (stuffvector prefix) + "Insert all the parts of STUFFVECTOR. +PREFIX specifies what to insert at the start of each line." + (let ((idx 0)) + (while (< idx (length stuffvector)) + (data-debug-insert-thing + ;; Some vectors may put a value in the CDR + (aref stuffvector idx) + prefix + "") + (setq idx (1+ idx))))) + +(defun data-debug-insert-stuff-vector-from-point (point) + "Insert the stuff found at the stuff vector button at POINT." + (let ((stuffvector (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start + ) + (end-of-line) + (setq start (point)) + (forward-char 1) + (data-debug-insert-stuff-vector stuffvector + (concat (make-string indent ? ) + "[ ")) + (goto-char start) + )) + +(defun data-debug-insert-stuff-vector-button (stuffvector + prefix + prebuttontext) + "Insert a button representing STUFFVECTOR. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the stuff vector button." + (let* ((start (point)) + (end nil) + (str (format "#<vector o' stuff: %d entries>" (length stuffvector))) + (tip str)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) + (put-text-property start end 'ddebug stuffvector) + (put-text-property start end 'ddebug-indent (length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-stuff-vector-from-point) + (insert "\n") + ) + ) + +;;; Symbol +;; + +(defun data-debug-insert-symbol-from-point (point) + "Insert attached properties and possibly the value of symbol at POINT." + (let ((symbol (get-text-property point 'ddebug)) + (indent (get-text-property point 'ddebug-indent)) + start) + (end-of-line) + (setq start (point)) + (forward-char 1) + (when (and (not (fboundp symbol)) (boundp symbol)) + (data-debug-insert-thing + (symbol-value symbol) + (concat (make-string indent ? ) "> ") + (concat + (dd-propertize "value" + 'face 'font-lock-comment-face) + " "))) + (data-debug-insert-property-list + (symbol-plist symbol) + (concat (make-string indent ? ) "> ")) + (goto-char start)) + ) + +(defun data-debug-insert-symbol-button (symbol prefix prebuttontext) + "Insert a button representing SYMBOL. + PREFIX is the text that preceeds the button. + PREBUTTONTEXT is some text between prefix and the symbol button." + (let ((string + (cond ((fboundp symbol) + (dd-propertize (concat "#'" (symbol-name symbol)) + 'face 'font-lock-function-name-face)) + ((boundp symbol) + (dd-propertize (concat "'" (symbol-name symbol)) + 'face 'font-lock-variable-name-face)) + (t (format "'%s" symbol))))) + (insert (dd-propertize + (concat prefix prebuttontext string) + 'ddebug symbol + 'ddebug-indent (length prefix) + 'ddebug-prefix prefix + 'help-echo "" + 'ddebug-function + 'data-debug-insert-symbol-from-point) + "\n")) + ) + +;;; String +(defun data-debug-insert-string (thing prefix prebuttontext) + "Insert one symbol THING. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (let ((newstr thing)) + (while (string-match "\n" newstr) + (setq newstr (replace-match "\\n" t t newstr))) + (while (string-match "\t" newstr) + (setq newstr (replace-match "\\t" t t newstr))) + (insert prefix prebuttontext + (dd-propertize (format "\"%s\"" newstr) + 'face font-lock-string-face) + "\n" ))) + +;;; Number +(defun data-debug-insert-number (thing prefix prebuttontext) + "Insert one symbol THING. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (insert prefix prebuttontext + (dd-propertize (format "%S" thing) + 'face font-lock-string-face) + "\n")) + +;;; Lambda Expression +(defun data-debug-insert-lambda-expression (thing prefix prebuttontext) + "Insert one lambda expression THING. +A Symbol is a simple thing, but this provides some face and prefix rules. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing." + (let ((txt (prin1-to-string thing))) + (data-debug-insert-simple-thing + txt prefix prebuttontext 'font-lock-keyword-face)) + ) + +;;; nil thing +(defun data-debug-insert-nil (thing prefix prebuttontext) + "Insert one simple THING with a face. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing. +FACE is the face to use." + (insert prefix prebuttontext) + (insert ": ") + (let ((start (point)) + (end nil)) + (insert "nil") + (setq end (point)) + (insert "\n" ) + (put-text-property start end 'face 'font-lock-variable-name-face) + )) + +;;; simple thing +(defun data-debug-insert-simple-thing (thing prefix prebuttontext face) + "Insert one simple THING with a face. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing. +FACE is the face to use." + (insert prefix prebuttontext) + (let ((start (point)) + (end nil)) + (insert (format "%s" thing)) + (setq end (point)) + (insert "\n" ) + (put-text-property start end 'face face) + )) + +;;; custom thing +(defun data-debug-insert-custom (thingstring prefix prebuttontext face) + "Insert one simple THINGSTRING with a face. +Use for simple items that need a custom insert. +PREFIX is the text that preceeds the button. +PREBUTTONTEXT is some text between prefix and the thing. +FACE is the face to use." + (insert prefix prebuttontext) + (let ((start (point)) + (end nil)) + (insert thingstring) + (setq end (point)) + (insert "\n" ) + (put-text-property start end 'face face) + )) + + +(defvar data-debug-thing-alist + '( + ;; nil + (null . data-debug-insert-nil) + + ;; Overlay + (data-debug-overlay-p . data-debug-insert-overlay-button) + + ;; Overlay list + ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) . + data-debug-insert-overlay-list-button) + + ;; Buffer + (bufferp . data-debug-insert-buffer-button) + + ;; Buffer list + ((lambda (thing) (and (consp thing) (bufferp (car thing)))) . + data-debug-insert-buffer-list-button) + + ;; Process + (processp . data-debug-insert-process-button) + + ;; String + (stringp . data-debug-insert-string) + + ;; Number + (numberp . data-debug-insert-number) + + ;; Symbol + (symbolp . data-debug-insert-symbol-button) + + ;; Ring + (ring-p . data-debug-insert-ring-button) + + ;; Lambda Expression + ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) . + data-debug-insert-lambda-expression) + + ;; Hash-table + (hash-table-p . data-debug-insert-hash-table-button) + + ;; Widgets + (widgetp . data-debug-insert-widget) + + ;; List of stuff + (listp . data-debug-insert-stuff-list-button) + + ;; Vector of stuff + (vectorp . data-debug-insert-stuff-vector-button) + ) + "Alist of methods used to insert things into an Ddebug buffer.") + +;; An augmentation function for the thing alist. +(defun data-debug-add-specialized-thing (predicate fcn) + "Add a new specialized thing to display with data-debug. +PREDICATE is a function that returns t if a thing is this new type. +FCN is a function that will display stuff in the data debug buffer." + (let ((entry (cons predicate fcn)) + ;; Specialized entries show up AFTER nil, + ;; but before listp, vectorp, symbolp, and + ;; other general things. Splice it into + ;; the beginning. + (first (nthcdr 0 data-debug-thing-alist)) + (second (nthcdr 1 data-debug-thing-alist)) + ) + (when (not (member entry data-debug-thing-alist)) + (setcdr first (cons entry second))))) + +;; uber insert method +(defun data-debug-insert-thing (thing prefix prebuttontext &optional parent) + "Insert THING with PREFIX. +PREBUTTONTEXT is some text to insert between prefix and the thing +that is not included in the indentation calculation of any children. +If PARENT is non-nil, it is somehow related as a parent to thing." + (when (catch 'done + (dolist (test data-debug-thing-alist) + (when (funcall (car test) thing) + (condition-case nil + (funcall (cdr test) thing prefix prebuttontext parent) + (error + (funcall (cdr test) thing prefix prebuttontext))) + (throw 'done nil)) + ) + nil) + (data-debug-insert-simple-thing (format "%S" thing) + prefix + prebuttontext + 'bold))) + +;;; MAJOR MODE +;; +;; The Ddebug major mode provides an interactive space to explore +;; complicated data structures. +;; +(defgroup data-debug nil + "data-debug group." + :group 'langauges) + +(defvar data-debug-mode-syntax-table + (let ((table (make-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; + (modify-syntax-entry ?\n ">" table) ;; Comment end + (modify-syntax-entry ?\" "\"" table) ;; String + (modify-syntax-entry ?\- "_" table) ;; Symbol + (modify-syntax-entry ?\\ "\\" table) ;; Quote + (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) + (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) + (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) + + table) + "Syntax table used in data-debug macro buffers.") + +(defvar data-debug-map + (let ((km (make-sparse-keymap))) + (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse) + (define-key km " " 'data-debug-expand-or-contract) + (define-key km "\C-m" 'data-debug-expand-or-contract) + (define-key km "n" 'data-debug-next) + (define-key km "p" 'data-debug-prev) + (define-key km "N" 'data-debug-next-expando) + (define-key km "P" 'data-debug-prev-expando) + km) + "Keymap used in data-debug.") + +(defcustom data-debug-mode-hook nil + "*Hook run when data-debug starts." + :group 'data-debug + :type 'hook) + +(defun data-debug-mode () + "Major-mode for the Analyzer debugger. + +\\{data-debug-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'data-debug-mode + mode-name "DATA-DEBUG" + comment-start ";;" + comment-end "") + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (set-syntax-table data-debug-mode-syntax-table) + (use-local-map data-debug-map) + (run-hooks 'data-debug-hook) + (buffer-disable-undo) + (set (make-local-variable 'font-lock-global-modes) nil) + (font-lock-mode -1) + ) + +;;;###autoload +(defun data-debug-new-buffer (name) + "Create a new data-debug buffer with NAME." + (let ((b (get-buffer-create name))) + (pop-to-buffer b) + (set-buffer b) + (erase-buffer) + (data-debug-mode) + b)) + +;;; Ddebug mode commands +;; +(defun data-debug-next () + "Go to the next line in the Ddebug buffer." + (interactive) + (forward-line 1) + (beginning-of-line) + (skip-chars-forward " *-><[]" (point-at-eol))) + +(defun data-debug-prev () + "Go to the next line in the Ddebug buffer." + (interactive) + (forward-line -1) + (beginning-of-line) + (skip-chars-forward " *-><[]" (point-at-eol))) + +(defun data-debug-next-expando () + "Go to the next line in the Ddebug buffer. +Contract the current line (if open) and expand the line +we move to." + (interactive) + (data-debug-contract-current-line) + (data-debug-next) + (data-debug-expand-current-line) + ) + +(defun data-debug-prev-expando () + "Go to the previous line in the Ddebug buffer. +Contract the current line (if open) and expand the line +we move to." + (interactive) + (data-debug-contract-current-line) + (data-debug-prev) + (data-debug-expand-current-line) + ) + +(defun data-debug-current-line-expanded-p () + "Return non-nil if the current line is expanded." + (let ((ti (current-indentation)) + (ni (condition-case nil + (save-excursion + (end-of-line) + (forward-char 1) + (current-indentation)) + (error 0)))) + (> ni ti))) + +(defun data-debug-line-expandable-p () + "Return non-nil if the current line is expandable. +Lines that are not expandable are assumed to not be contractable." + (not (get-text-property (point) 'ddebug-noexpand))) + +(defun data-debug-expand-current-line () + "Expand the current line (if possible). +Do nothing if already expanded." + (when (or (not (data-debug-line-expandable-p)) + (not (data-debug-current-line-expanded-p))) + ;; If the next line is the same or less indentation, expand. + (let ((fcn (get-text-property (point) 'ddebug-function))) + (when fcn + (funcall fcn (point)) + (beginning-of-line) + )))) + +(defun data-debug-contract-current-line () + "Contract the current line (if possible). +Do nothing if already expanded." + (when (and (data-debug-current-line-expanded-p) + ;; Don't contract if the current line is not expandable. + (get-text-property (point) 'ddebug-function)) + (let ((ti (current-indentation)) + ) + ;; If next indentation is larger, collapse. + (end-of-line) + (forward-char 1) + (let ((start (point)) + (end nil)) + (condition-case nil + (progn + ;; Keep checking indentation + (while (or (> (current-indentation) ti) + (looking-at "^\\s-*$")) + (end-of-line) + (forward-char 1)) + (setq end (point)) + ) + (error (setq end (point-max)))) + (delete-region start end) + (forward-char -1) + (beginning-of-line))))) + +(defun data-debug-expand-or-contract () + "Expand or contract anything at the current point." + (interactive) + (if (and (data-debug-line-expandable-p) + (data-debug-current-line-expanded-p)) + (data-debug-contract-current-line) + (data-debug-expand-current-line)) + (skip-chars-forward " *-><[]" (point-at-eol))) + +(defun data-debug-expand-or-contract-mouse (event) + "Expand or contract anything at event EVENT." + (interactive "e") + (let* ((win (car (car (cdr event)))) + ) + (select-window win t) + (save-excursion + ;(goto-char (window-start win)) + (mouse-set-point event) + (data-debug-expand-or-contract)) + )) + +;;; GENERIC STRUCTURE DUMP +;; +(defun data-debug-show-stuff (stuff name) + "Data debug STUFF in a buffer named *NAME DDebug*." + (data-debug-new-buffer (concat "*" name " DDebug*")) + (data-debug-insert-thing stuff "?" "") + (goto-char (point-min)) + (when (data-debug-line-expandable-p) + (data-debug-expand-current-line))) + +;;; DEBUG COMMANDS +;; +;; Various commands for displaying complex data structures. + +(defun data-debug-edebug-expr (expr) + "Dump out the contets of some expression EXPR in edebug with ddebug." + (interactive + (list (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Eval: " + nil read-expression-map t + 'read-expression-history)) + )) + (let ((v (eval expr))) + (if (not v) + (message "Expression %s is nil." expr) + (data-debug-show-stuff v "expression")))) + +(defun data-debug-eval-expression (expr) + "Evaluate EXPR and display the value. +If the result is something simple, show it in the echo area. +If the result is a list or vector, then use the data debugger to display it." + (interactive + (list (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Eval: " + nil read-expression-map t + 'read-expression-history)) + )) + + (if (null eval-expression-debug-on-error) + (setq values (cons (eval expr) values)) + (let ((old-value (make-symbol "t")) new-value) + ;; Bind debug-on-error to something unique so that we can + ;; detect when evaled code changes it. + (let ((debug-on-error old-value)) + (setq values (cons (eval expr) values)) + (setq new-value debug-on-error)) + ;; If evaled code has changed the value of debug-on-error, + ;; propagate that change to the global binding. + (unless (eq old-value new-value) + (setq debug-on-error new-value)))) + + (if (or (consp (car values)) (vectorp (car values))) + (let ((v (car values))) + (data-debug-show-stuff v "Expression")) + ;; Old style + (prog1 + (prin1 (car values) t) + (let ((str (eval-expression-print-format (car values)))) + (if str (princ str t)))))) + +(provide 'data-debug) + +(if (featurep 'eieio) + (require 'eieio-datadebug)) + +;;; data-debug.el ends here |