lisp/cedet/data-debug.el

   1 ;;; data-debug.el --- Datastructure Debugger
   2
   3 ;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam  <zappo@gnu.org>
   6 ;; Version: 0.2
   7 ;; Keywords: OO, lisp
   8 ;; Package: cedet
   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.
 115 PREFIX is the text that precedes the button.
 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.
 164 PREFIX is the text that precedes the button.
 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.
 219 PREFIX is the text that precedes the button.
 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.
 268 PREFIX is the text that precedes the button.
 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.
 324 PREFIX is the text that precedes the button.
 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.
 376 PREFIX is the text that precedes the button.
 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.
 485 PREFIX is the text that precedes the button.
 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.
 538 PREFIX is the text that precedes the button.
 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.
 597 PREFIX is the text that precedes the button.
 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.
 643 PREFIX is the text that precedes the button.
 644 PREBUTTONTEXT is some text between prefix and the symbol button."
 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.
 668 PREFIX is the text that precedes the button.
 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.
 684 PREFIX is the text that precedes the button.
 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.
 695 PREFIX is the text that precedes the button.
 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.
 705 PREFIX is the text that precedes the button.
 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.
 721 PREFIX is the text that precedes the button.
 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.
 737 PREFIX is the text that precedes the button.
 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   (let ((inhibit-read-only t))
 825     (when (catch 'done
 826             (dolist (test data-debug-thing-alist)
 827               (when (funcall (car test) thing)
 828                 (condition-case nil
 829                     (progn
 830                       (funcall (cdr test) thing prefix prebuttontext parent)
 831                       (throw 'done nil))
 832                   (error
 833                    (condition-case nil
 834                        (progn
 835                          (funcall (cdr test) thing prefix prebuttontext)
 836                          (throw 'done nil))
 837                      (error nil))))
 838                 ;; Only throw the 'done if no error was caught.
 839                 ;; If an error was caught, skip this predicate as being
 840                 ;; unsuccessful, and move on.
 841                 ))
 842             nil)
 843       (data-debug-insert-simple-thing (format "%S" thing)
 844                                       prefix
 845                                       prebuttontext
 846                                       'bold)))
 847   (set-buffer-modified-p nil))
 848
 849 ;;; MAJOR MODE
 850 ;;
 851 ;; The Ddebug major mode provides an interactive space to explore
 852 ;; complicated data structures.
 853 ;;
 854 (defgroup data-debug nil
 855   "data-debug group."
 856   :group 'extensions)
 857
 858 (defvar data-debug-mode-syntax-table
 859   (let ((table (make-syntax-table (standard-syntax-table))))
 860     (modify-syntax-entry ?\; ". 12"  table) ;; SEMI, Comment start ;;
 861     (modify-syntax-entry ?\n ">"     table) ;; Comment end
 862     (modify-syntax-entry ?\" "\""    table) ;; String
 863     (modify-syntax-entry ?\- "_"     table) ;; Symbol
 864     (modify-syntax-entry ?\\ "\\"    table) ;; Quote
 865     (modify-syntax-entry ?\` "'"     table) ;; Prefix ` (backquote)
 866     (modify-syntax-entry ?\' "'"     table) ;; Prefix ' (quote)
 867     (modify-syntax-entry ?\, "'"     table) ;; Prefix , (comma)
 868
 869     table)
 870   "Syntax table used in data-debug macro buffers.")
 871
 872 (defvar data-debug-map
 873   (let ((km (make-sparse-keymap)))
 874     (suppress-keymap km)
 875     (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse)
 876     (define-key km " " 'data-debug-expand-or-contract)
 877     (define-key km "\C-m" 'data-debug-expand-or-contract)
 878     (define-key km "n" 'data-debug-next)
 879     (define-key km "p" 'data-debug-prev)
 880     (define-key km "N" 'data-debug-next-expando)
 881     (define-key km "P" 'data-debug-prev-expando)
 882     km)
 883   "Keymap used in data-debug.")
 884
 885 (defcustom data-debug-mode-hook nil
 886   "Hook run when data-debug starts."
 887   :group 'data-debug
 888   :type 'hook)
 889
 890 (defun data-debug-mode ()
 891   "Major-mode for the Analyzer debugger.
 892
 893 \\{data-debug-map}"
 894   (interactive)
 895   (kill-all-local-variables)
 896   (setq major-mode 'data-debug-mode
 897         mode-name "DATA-DEBUG"
 898         comment-start ";;"
 899         comment-end ""
 900         buffer-read-only t)
 901   (set (make-local-variable 'comment-start-skip)
 902        "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
 903   (set-syntax-table data-debug-mode-syntax-table)
 904   (use-local-map data-debug-map)
 905   (run-hooks 'data-debug-hook)
 906   (buffer-disable-undo)
 907   (set (make-local-variable 'font-lock-global-modes) nil)
 908   (font-lock-mode -1)
 909   )
 910
 911 ;;;###autoload
 912 (defun data-debug-new-buffer (name)
 913   "Create a new data-debug buffer with NAME."
 914   (let ((b (get-buffer-create name)))
 915     (pop-to-buffer b)
 916     (set-buffer b)
 917     (setq buffer-read-only nil) ; disable read-only
 918     (erase-buffer)
 919     (data-debug-mode)
 920     b))
 921
 922 ;;; Ddebug mode commands
 923 ;;
 924 (defun data-debug-next ()
 925   "Go to the next line in the Ddebug buffer."
 926   (interactive)
 927   (forward-line 1)
 928   (beginning-of-line)
 929   (skip-chars-forward " *-><[]" (point-at-eol)))
 930
 931 (defun data-debug-prev ()
 932   "Go to the previous line in the Ddebug buffer."
 933   (interactive)
 934   (forward-line -1)
 935   (beginning-of-line)
 936   (skip-chars-forward " *-><[]" (point-at-eol)))
 937
 938 (defun data-debug-next-expando ()
 939   "Go to the next line in the Ddebug buffer.
 940 Contract the current line (if open) and expand the line
 941 we move to."
 942   (interactive)
 943   (data-debug-contract-current-line)
 944   (data-debug-next)
 945   (data-debug-expand-current-line)
 946   )
 947
 948 (defun data-debug-prev-expando ()
 949   "Go to the previous line in the Ddebug buffer.
 950 Contract the current line (if open) and expand the line
 951 we move to."
 952   (interactive)
 953   (data-debug-contract-current-line)
 954   (data-debug-prev)
 955   (data-debug-expand-current-line)
 956   )
 957
 958 (defun data-debug-current-line-expanded-p ()
 959   "Return non-nil if the current line is expanded."
 960   (let ((ti (current-indentation))
 961         (ni (condition-case nil
 962                 (save-excursion
 963                   (end-of-line)
 964                   (forward-char 1)
 965                   (current-indentation))
 966               (error 0))))
 967     (> ni ti)))
 968
 969 (defun data-debug-line-expandable-p ()
 970   "Return non-nil if the current line is expandable.
 971 Lines that are not expandable are assumed to not be contractible."
 972   (not (get-text-property (point) 'ddebug-noexpand)))
 973
 974 (defun data-debug-expand-current-line ()
 975   "Expand the current line (if possible).
 976 Do nothing if already expanded."
 977   (when (or (not (data-debug-line-expandable-p))
 978             (not (data-debug-current-line-expanded-p)))
 979     ;; If the next line is the same or less indentation, expand.
 980     (let ((fcn (get-text-property (point) 'ddebug-function))
 981           (inhibit-read-only t))
 982       (when fcn
 983         (funcall fcn (point))
 984         (beginning-of-line)
 985         ))))
 986
 987 (defun data-debug-contract-current-line ()
 988   "Contract the current line (if possible).
 989 Do nothing if already contracted."
 990   (when (and (data-debug-current-line-expanded-p)
 991              ;; Don't contract if the current line is not expandable.
 992              (get-text-property (point) 'ddebug-function))
 993     (let ((ti (current-indentation))
 994           (inhibit-read-only t)
 995           )
 996       ;; If next indentation is larger, collapse.
 997       (end-of-line)
 998       (forward-char 1)
 999       (let ((start (point))
1000             (end nil))
1001         (condition-case nil
1002             (progn
1003               ;; Keep checking indentation
1004               (while (or (> (current-indentation) ti)
1005                          (looking-at "^\\s-*$"))
1006                 (end-of-line)
1007                 (forward-char 1))
1008               (setq end (point))
1009               )
1010           (error (setq end (point-max))))
1011         (delete-region start end)
1012         (forward-char -1)
1013         (beginning-of-line))))
1014   (set-buffer-modified-p nil))
1015
1016 (defun data-debug-expand-or-contract ()
1017   "Expand or contract anything at the current point."
1018   (interactive)
1019   (if (and (data-debug-line-expandable-p)
1020            (data-debug-current-line-expanded-p))
1021       (data-debug-contract-current-line)
1022     (data-debug-expand-current-line))
1023   (skip-chars-forward " *-><[]" (point-at-eol)))
1024
1025 (defun data-debug-expand-or-contract-mouse (event)
1026   "Expand or contract anything at event EVENT."
1027   (interactive "e")
1028   (let* ((win (car (car (cdr event))))
1029          )
1030     (select-window win t)
1031     (save-excursion
1032       ;(goto-char (window-start win))
1033       (mouse-set-point event)
1034       (data-debug-expand-or-contract))
1035     ))
1036
1037 ;;; GENERIC STRUCTURE DUMP
1038 ;;
1039 (defun data-debug-show-stuff (stuff name)
1040   "Data debug STUFF in a buffer named *NAME DDebug*."
1041   (data-debug-new-buffer (concat "*" name " DDebug*"))
1042   (data-debug-insert-thing stuff "?" "")
1043   (goto-char (point-min))
1044   (when (data-debug-line-expandable-p)
1045     (data-debug-expand-current-line)))
1046
1047 ;;; DEBUG COMMANDS
1048 ;;
1049 ;; Various commands for displaying complex data structures.
1050
1051 (defun data-debug-edebug-expr (expr)
1052   "Dump out the contents of some expression EXPR in edebug with ddebug."
1053   (interactive
1054    (list (let ((minibuffer-completing-symbol t))
1055            (read-from-minibuffer "Eval: "
1056                                  nil read-expression-map t
1057                                  'read-expression-history))
1058          ))
1059   (let ((v (eval expr)))
1060     (if (not v)
1061         (message "Expression %s is nil." expr)
1062       (data-debug-show-stuff v "expression"))))
1063
1064 (defun data-debug-eval-expression (expr)
1065   "Evaluate EXPR and display the value.
1066 If the result is something simple, show it in the echo area.
1067 If the result is a list or vector, then use the data debugger to display it."
1068   (interactive
1069    (list (let ((minibuffer-completing-symbol t))
1070            (read-from-minibuffer "Eval: "
1071                                  nil read-expression-map t
1072                                  'read-expression-history))
1073          ))
1074
1075   (if (null eval-expression-debug-on-error)
1076       (setq values (cons (eval expr) values))
1077     (let ((old-value (make-symbol "t")) new-value)
1078       ;; Bind debug-on-error to something unique so that we can
1079       ;; detect when evalled code changes it.
1080       (let ((debug-on-error old-value))
1081         (setq values (cons (eval expr) values))
1082         (setq new-value debug-on-error))
1083       ;; If evalled code has changed the value of debug-on-error,
1084       ;; propagate that change to the global binding.
1085       (unless (eq old-value new-value)
1086         (setq debug-on-error new-value))))
1087
1088   (if (or (consp (car values)) (vectorp (car values)))
1089       (let ((v (car values)))
1090         (data-debug-show-stuff v "Expression"))
1091     ;; Old style
1092     (prog1
1093         (prin1 (car values) t)
1094       (let ((str (eval-expression-print-format (car values))))
1095         (if str (princ str t))))))
1096
1097 (provide 'data-debug)
1098
1099 ;;; data-debug.el ends here