code.delx.au - gnu-emacs/blob - lisp/cedet/data-debug.el

   1 ;;; data-debug.el --- Datastructure Debugger
   2
   3 ;; Copyright (C) 2007, 2008, 2009, 2010, 2011  Free Software Foundation, Inc.
   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.
 114 PREFIX is the text that precedes the button.
 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.
 163 PREFIX is the text that precedes the button.
 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.
 218 PREFIX is the text that precedes the button.
 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.
 267 PREFIX is the text that precedes the button.
 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.
 323 PREFIX is the text that precedes the button.
 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.
 375 PREFIX is the text that precedes the button.
 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.
 484 PREFIX is the text that precedes the button.
 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.
 537 PREFIX is the text that precedes the button.
 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.
 596 PREFIX is the text that precedes the button.
 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.
 642 PREFIX is the text that precedes the button.
 643 PREBUTTONTEXT is some text between prefix and the symbol button."
 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.
 667 PREFIX is the text that precedes the button.
 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.
 683 PREFIX is the text that precedes the button.
 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.
 694 PREFIX is the text that precedes the button.
 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.
 704 PREFIX is the text that precedes the button.
 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.
 720 PREFIX is the text that precedes the button.
 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.
 736 PREFIX is the text that precedes the button.
 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."
 845   :group 'extensions)
 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)
1035   "Dump out the contents of some expression EXPR in edebug with ddebug."
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
1085 ;; arch-tag: 4807227d-08e7-45c4-8ea5-9e4595c3bfb1
1086 ;;; data-debug.el ends here